perm filename PCPS4.PAS[S1,ALS] blob
sn#378170 filedate 1978-11-20 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00024 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 (*$D+,R32*) (*PDP-10 PASCAL options*) (*XPORT*)
C00011 00003 CONST DISPLIMIT = 20 MAXLEVEL = 10
C00013 00004 TYPE (*DESCRIBING:*)
C00020 00005 VAR
C00027 00006 PROCEDURE PRINTERROR
C00031 00007 PROCEDURE INSYMBOL
C00043 00008 PROCEDURE ENTERID(FCP: CTP)
C00053 00009 PROCEDURE FOLLOWCTP
C00065 00010 FUNCTION STRING(FSP: STP) : BOOLEAN
C00084 00011 PROCEDURE LABELDECLARATION
C00100 00012 BEGIN (*PROCDECLARATION*)
C00111 00013 PROCEDURE GEN0(FOP: OPRANGE)
C00123 00014 PROCEDURE PUTLABEL(LABNAME: INTEGER)
C00134 00015 PROCEDURE CALL(FSYS: SETOFSYS FCP: CTP)
C00145 00016 PROCEDURE NEW1
C00160 00017 BEGIN (*CALL*)
C00169 00018 BEGIN (*TERM*)
C00180 00019 PROCEDURE ASSIGNMENT(FCP: CTP)
C00192 00020 PROCEDURE REPEATSTATEMENT
C00203 00021 BEGIN (*BODY*)
C00213 00022 PROCEDURE PROGRAMME(FSYS:SETOFSYS)
C00226 00023 PROCEDURE INITSCALARS
C00238 00024 BEGIN (*PASCALCOMPILER*)
C00241 ENDMK
C⊗;
(*$D+,R32*) (*PDP-10 PASCAL options*) (*XPORT*)
PROGRAM PASCALCOMPILER(INPUT*,OUTPUT,PRR) (*INPUT,OUTPUT,PRR*);
(* (old) T-,L+,C+,M-,S+,F-,P-,D-,E-,D+*)
(*********************************************************
* *
* *
* STEP-WISE DEVELOPMENT OF A PASCAL COMPILER *
* ****************************************** *
* *
* *
* STEP 5: SYNTAX ANALYSIS INCLUDING ERROR *
* HANDLING; CHECKS BASED ON DECLARA- *
* 10/7/73 TIONS; ADDRESS AND CODE GENERATION *
* FOR A HYPOTHETICAL STACK COMPUTER *
* *
* *
* AUTHOR: URS AMMANN *
* FACHGRUPPE COMPUTERWISSENSCHAFTEN *
* EIDG. TECHNISCHE HOCHSCHULE *
* CH-8006 ZUERICH *
* *
* *
* *
* MODIFICATION OF STEP 5 OF PASCAL COMPILER *
* ***************************************** *
* *
* THE COMPILER IS NOW WRITTEN IN A SUBSET OF *
* STANDARD PASCAL - AS DEFINED IN THE NEW *
* MANUAL BY K. JENSEN AND N. WIRTH - AND IT *
* PROCESSES EXACTLY THIS SUBSET. *
* *
* AUTHOR OF CHANGES: KESAV NORI *
* COMPUTER GROUP *
* T.I.F.R. *
* HOMI BHABHA ROAD *
* BOMBAY - 400005 *
* INDIA *
* *
* THESE CHANGES WERE COMPLETED AT ETH, ZURICH *
* ON 20/5/74. *
* *
* *
* *
* +++++++++++++++++++++++++++++++++++++++++++ *
* *
* *
* *
* THE COMPILER IS NOW CHANGED TO: *
* ******************************* *
* *
* *
* -PRODUCE THE INTERMEDIATE CODE IN AN *
* ASSEMBLER READABLE FORM (NAMELY THE *
* 370, ASSEMBLER←H), 15-NOV-75. *
* *
* -PRESERVE PROCEDURE NAMES AND THEIR *
* STATIC LEVELS AT THE OBJECT LEVEL, THUS *
* ALLOWING A SET OF 'DISPLAY' REGISTERS TO *
* BE USED IN ACCESSING NON←LOCAL, NON←GLOBAL *
* VARIABLES (INSTEAD OF GOING THROUGH A *
* CHAIN OF POINTERS), 10-DEC-75. *
* *
* -INCLUDE THE TYPE OF THE OPERANDS IN THE *
* P←INSTRUCTIONS AS FOLLOWS: *
* *
* A : ADDRESS (POINTER) OPERAND *
* B : BOOLEAN " *
* C : CHARACTER " *
* I : INTEGER " *
* R : REAL " *
* S : SET " *
* *
* THE P←INSTRUCTION NOW LOOKS LIKE: *
* (LAB) OPCODE (TYPE),(OPERANDS) *
* A NEW PROCEDURE 'EXIT(RC: INTEGER)' IS *
* ADDED TO THE SET OF STANDARD PROCEDURES *
* TO FACILITATE TERMINATING A PROGRAM AT *
* ANY POINT AND RETURNING A 'RETURN CODE' *
* TO THE OPERATING SYSTEM, 26-JAN-76. *
* *
* -TREAT THE INPUT AS A TEXT FILE WITH *
* LINES (RECORDS) OF 80 CHARACTER EACH, *
* THIS ALLOWS A MORE EFFICIENT STRING *
* ORIENTED INPUT, 20-MAR-76. *
* *
* -ALLOCATE AND PROPERLY ALIGN VARIABLES ON *
* THE BASIS OF THEIR TYPES, I.E. *
* *
* TYPE SIZE ALIGNED ON *
* *
* B,C 1-BYTE 1-BYTE *
* A,I 4-BYTES 4-BYTE *
* S 8-BYTES 4-BYTE *
* R 8-BYTES 8-BYTE *
* *
* DYNAMIC STORAGE HOWEVER IS ALWAYS ALLOC- *
* CATED ON 8-BYTE BOUNDARIES TO AVOID RUN- *
* TIME CHECKING OVERHEAD, 25-APR-76. *
* *
* -'READ' OF 'STRING' VARIABLES (I.E. ARRAY *
* OF CHAR) IS NOW IMPLEMENTED AND IT IS TO *
* COMPLEMENT THE SIMILAR 'WRITE' FUNCTION. *
* ALSO THE STANDARD PROCEDURE: *
* TRAP(I: INTEGER; VAR V: [ANY TYPE] ); *
* IS ADDED TO THE SET OF STANDARD PROCEDURES *
* TO FACILITATE COMMUNICATION WITH THE OUT- *
* SIDE WORLD, 10-SEP-76. *
* *
* -RELEVENT INFORMATION ON/ABOUT PROCEDURES *
* ARE NOW SENT TO 'QRR' FILE. THIS INCLUDES *
* SUCH INFORMATION AS THE SIZE OF THE PROCE- *
* DURE AS WELL AS ITS DATA AREA, LIST OF THE *
* PROCEDURES CALLED AND THE # OF CALLS, THE *
* LEVEL OF THE HIGHEST←LEVEL PROCEDURE CALLED *
* ETC. THIS INFORMATION IS MAINLY INTENDED *
* FOR INTER←PROCEDURAL ANALYSIS, BUT IT IS *
* ALSO USEFUL FOR MORE EFFICIENT PROCEDURE *
* ENTRY/EXIT CODE, 22-MAR-77. *
* *
* *
* THE ABOVE CHANGES (INCLUDING ADDITIONS AND/OR *
* DELETIONS) HAVE BEEN TAGGED BY A '#' TAG AT *
* THE BEGINNING OR THE END OF AFFECTED LINES. *
* *
* *
* *
* S. HAZEGHI *
* *
* COMPUTATION RESEARCH GROUP *
* S.L.A.C. *
* *
* *
* *
*********************************************************)
CONST DISPLIMIT = 20; MAXLEVEL = 10;
%S0\ % MAXADDR = 16777215;\
%S1\ MAXADDR = 1073741823;
%S1\ INTSIZE = 4; REALSIZE = 4;
CHARSIZE = 1; BOOLSIZE = 1; SETSIZE =8; PTRSIZE = 4;
%S0\ % LCAFTMST = 80; FPSAVEAREA = 32 ; RUNCHKAREA = 96 ; \
%S0\ % DSPLYAREA = 72 ; FNCRSLT = 72 ; \
%S0\ % "* SAVE AREAS, FUNCTION RETURN VALUE SPACE, DISPLAY AREA, ETC. *" \
%S0\ % FIRSTFILBUF = 248 ; "* = LCAFTMST+RUNCHKAREA+DSPLYAREA *" \
%S0\ % LASTFILBUF = 280 ; "* LAST FILE BUFFER / FIRST PROG. VARIABLE *" \
%S1\ (* 'S1' CONSTANT DEFINITION *)
%S1\ REGPRMAREA = 40 ; (* SHOULD BE A MULTIPLE OF '4' BYTES *)
%S1\ LCAFTMST = 8 ; FPSAVEAREA = 0 ; RUNCHKAREA = 0 ; DSPLYAREA = 0 ;
%S1\ FNCRSLT = 0 ; FIRSTFILBUF = 12 ; LASTFILBUF = 44 ;
REALLNGTH = 20 ; DIGMAX = 19 (* REALLNGHT-1*) ; IDLNGTH = 12 ;
STRGLNGTH = 64;
%S0\ % MAXINT = 2147483647; \
%S1\ MAXINT = 34359738367;
SETRANGE = 63 ; ALPHABETRANGE = SETRANGE ;
OPMAX = 64 ; (* OPCODE RANGE *)
BLANK12 = ' ' ;
%CTR\ MAXCTR = 16384 ;
TYPE (*DESCRIBING:*)
(*************)
(*BASIC SYMBOLS*)
(***************)
SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,FUNCSY,PROGSY,
PROCSY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,
BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,
GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
THENSY,OTHERSY);
OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP,
NEOP,EQOP,INOP,NOOP);
SETOFSYS = SET OF SYMBOL;
(*CONSTANTS*)
(***********)
CSTCLASS = (REEL,PSET,STRG);
CSP = ↑ CONSTANT;
CONSTANT = RECORD CASE %CCLASS:\ CSTCLASS OF
REEL: (RVAL: PACKED ARRAY [1..REALLNGTH] OF CHAR);
PSET: (PVAL: SET OF 0..SETRANGE);
STRG: (SLNGTH: 0..STRGLNGTH;
SVAL: PACKED ARRAY [1..STRGLNGTH] OF CHAR)
END;
VALU = RECORD CASE %INTVAL:\ BOOLEAN OF (*INTVAL NEVER SET NORE TESTED*)
TRUE: (IVAL: INTEGER);
FALSE: (VALP: CSP)
END;
(*DATA STRUCTURES*)
(*****************)
LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR;
ALNRNG = 1..8 ; LABELRNG = 0..1000 ;
STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,
TAGFLD,VARIANT);
DECLKIND = (STANDARD,DECLARED);
STP = ↑ STRUCTURE; CTP = ↑ IDENTIFIER;
STRUCTURE = PACKED RECORD
(* MARKED: BOOLEAN; TO BE USED WITH 'T+', FOR TEST PHASE ONLY*)
ALN : ALNRNG ; (*REQUIRED ALIGNMENT *)
SIZE: ADDRRANGE;
CASE FORM: STRUCTFORM OF
SCALAR: (CASE SCALKIND: DECLKIND OF
DECLARED: (FCONST: CTP));
SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU);
POINTER: (ELTYPE: STP);
POWER: (ELSET: STP);
ARRAYS: (AELTYPE,INXTYPE: STP);
RECORDS: (FSTFLD: CTP; RECVAR: STP);
FILES: (FILTYPE: STP);
TAGFLD: (TAGFIELDP: CTP; FSTVAR: STP);
VARIANT: (NXTVAR,SUBVAR: STP; VARVAL: VALU)
END;
(*NAMES*)
(*******)
IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC);
SETOFIDS = SET OF IDCLASS;
IDKIND = (ACTUAL,FORMAL);
ALPHA = PACKED ARRAY [1..IDLNGTH] OF CHAR;
IDENTIFIER = PACKED RECORD
NAME: ALPHA; LLINK, RLINK: CTP;
IDTYPE: STP; NEXT: CTP;
CASE KLASS: IDCLASS OF
KONST: (VALUES: VALU);
VARS: (VKIND: IDKIND; EBCD: BOOLEAN ;
VLEV: LEVRANGE; VADDR: ADDRRANGE);
FIELD: (FLDADDR: ADDRRANGE);
PROC,
FUNC: (CASE PFDECKIND: DECLKIND OF
STANDARD: (KEY: 1..15);
DECLARED: (PFLEV: LEVRANGE; PFNAME: LABELRNG;
%S1\ FPRMSZE,RPRMSZE,SPRMSZE: ADDRRANGE;
CASE PFKIND: IDKIND OF
ACTUAL: (FORWDECL, XTERN,SAVEFP:
BOOLEAN)))
END;
DISPRANGE = 0..DISPLIMIT;
WHERE = (BLCK,CREC,VREC,REC);
(*EXPRESSIONS*)
(*************)
ATTRKIND = (CST,VARBL,EXPR);
VACCESS = (DRCT,INDRCT,INXD);
ATTR = RECORD TYPTR, BTYPE: STP;
CASE KIND: ATTRKIND OF
CST: (CVAL: VALU);
VARBL: (CASE ACCESS: VACCESS OF
DRCT: (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE);
INDRCT: (IDPLMT: ADDRRANGE))
END;
TESTP = ↑ TESTPOINTER;
TESTPOINTER = PACKED RECORD
ELT1,ELT2 : STP;
LASTTESTP : TESTP
END;
(*LABELS*)
(********)
LBP = ↑ LABL;
LABL = RECORD NEXTLAB: LBP; DEFINED: BOOLEAN;
LABVAL, LABNAME: INTEGER
END;
EXTFILEP = ↑FILEREC;
FILEREC = RECORD FILENAME:ALPHA; NEXTFILE:EXTFILEP; GEBCDFIL: BOOLEAN END;
%CTR\ CTRRANGE = 0..MAXCTR;
%CTR\ CTRTYPE = (CTRPROC, CTRLBL, CTRGOTO, CTRIF, CTRWHILE, CTRREPEAT,
%CTR\ CTRFOR, CTRCASE);
(*-------------------------------------------------------------------------*)
VAR
PRD, PRR, QRD , QRR : TEXT;
ERRORCOUNT, CTIME: INTEGER ; (*TOTAL ERROR COUNT*)
(*RETURNED BY SOURCE PROGRAM SCANNER
INSYMBOL:
**********)
SY: SYMBOL; (*LAST SYMBOL*)
OP: OPERATOR; (*CLASSIFICATION OF LAST SYMBOL*)
VAL: VALU; (*VALUE OF LAST CONSTANT*)
LNGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*)
ID: ALPHA ; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)*)
KK: 1..IDLNGTH; (*NR OF CHARS IN LAST IDENTIFIER*)
CH: CHAR; (*LAST CHARACTER READ*)
EOL: BOOLEAN; (*END OF LINE FLAG*)
(*COUNTERS:*)
(***********)
CHCNT: 0..81; (*CHARACTER COUNTER*)
LC,IC,OLDIC: ADDRRANGE ; (*DATA LOCATION AND INSTRUCTION COUNTER*)
LINECOUNT ,MXDATASZE: INTEGER;
(*SWITCHES:*)
(***********)
DP, (*DECLARATION PART*)
PRTERR, (*TO ALLOW FORWARD REFERENCES IN PTR TYPE
(*DECLARATION BY SUPPRESSING ERROR MSG*)
ASSIGN,PACKDATA, (*ASSIGNMENT GOING ON, WORD ALIGN FLAG *)
LIST,PRCODE,PRTABLES,PRTIC,
MARGIN,DEBUG,BYTEON,
(*OUTPUT OPTIONS FOR
--> SOURCE PROGRAM LISTING
--> PRINTING SYMBOLIC CODE
--> DISPLAYING IDENT AND STRUCT TABLES
--> SET INPUT MARGIN AT 72 COLS.
--> PRINT INST←CNTR, PROCEDURE OPTION*)
ASSEMBLE,ASMVERB,EBCDFLG,
SAVEREGS,SAVEFPRS,GET←STAT: BOOLEAN;
(*POST PROCESSOR OPTIONS*)
(*POINTERS:*)
(***********)
INTPTR,REALPTR,CHARPTR,
BOOLPTR,NILPTR,TEXTPTR: STP; (*POINTERS TO ENTRIES OF STANDARD IDS*)
UTYPPTR,UCSTPTR,UVARPTR,
UFLDPTR,UPRCPTR,UFCTPTR, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*)
FWPTR: CTP; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*)
FEXTFILEP: EXTFILEP; (*HEAD OF CHAIN OF EXTERNAL FILES*)
GLOBTESTP: TESTP; (*LAST TESTPOINTER*)
(*BOOKKEEPING OF DECLARATION LEVELS:*)
(************************************)
LEVEL: LEVRANGE; (*CURRENT STATIC LEVEL*)
DISX, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*)
TOP: DISPRANGE; (*TOP OF DISPLAY*)
DISPLAY: (*WHERE: MEANS:*)
ARRAY [DISPRANGE] OF
PACKED RECORD (*=BLCK: ID IS VARIABLE ID*)
FNAME: CTP; FLABEL: LBP; (*=CREC: ID IS FIELD ID IN RECORD WITH*)
CASE OCCUR: WHERE OF (* CONSTANT ADDRESS*)
CREC: (CLEV: LEVRANGE; (*=VREC: ID IS FIELD ID IN RECORD WITH*)
CDSPL: ADDRRANGE);(* VARIABLE ADDRESS*)
VREC: (VDSPL: ADDRRANGE)
END; (* --> PROCEDURE WITHSTATEMENT*)
(*ERROR MESSAGES:*)
(*****************)
ERRINX: 0..10; (*NR OF ERRORS IN CURRENT SOURCE LINE*)
ERRLIST:
ARRAY [1..10] OF
PACKED RECORD POS: 1..81;
NMR: 1..400
END;
(*EXPRESSION COMPILATION:*)
(*************************)
GATTR: ATTR; (*DESCRIBES THE EXPR CURRENTLY COMPILED*)
(*STRUCTURED CONSTANTS:*)
(***********************)
ATOZ, NUMERIC,
ALPHANUMERIC : SET OF CHAR ; (*VALID ALPHA-NUMERICS*)
LINEBUF: ARRAY[1..81] OF CHAR ; (*CURRENT LINE BUFFER*)
SEQFLD: ARRAY [1..8] OF CHAR ; (*SEQ. NUM. FIELD OF INPUT LINE, $M+ ONLY*)
CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
STATBEGSYS,TYPEDELS: SETOFSYS;
NXTFILBUF : ADDRRANGE ;
CALL←LVL : ARRAY[BOOLEAN] OF INTEGER ;
RW: ARRAY [1..35(*NR. OF RES. WORDS*)] OF ALPHA;
FRW: ARRAY [1..14] OF 1..36(*NR. OF RES. WORDS + 1*);
RSY: ARRAY [1..35(*NR. OF RES. WORDS*)] OF SYMBOL;
SSY: ARRAY [' '..'←'] OF SYMBOL;
ROP: ARRAY [1..35(*NR. OF RES. WORDS*)] OF OPERATOR;
SOP: ARRAY [' '..'←'] OF OPERATOR;
NA: ARRAY [1..45] OF ALPHA;
MN: ARRAY [0..OPMAX] OF PACKED ARRAY [1..4] OF CHAR;
SNA: ARRAY [1..32] OF PACKED ARRAY [1..3] OF CHAR;
INTLABEL,PROCLAB: LABELRNG ; MXINT10: INTEGER;
%CTR\ CTRCNT : CTRRANGE ;
%CTR\ CTRCNTLBL : LABELRNG ;
%CTR\ CTROPTION : BOOLEAN;
%CTR\ % FIRSTCTR : BOOLEAN; \
%S1\ FPRM1, SPRM1, RPRM1 : ADDRRANGE ; REGS←FULL: BOOLEAN ;
(*-------------------------------------------------------------------------*)
procedure EXITT (CODE : integer);
begin
WRITELN(OUTPUT,'**** EXITT called with code =',CODE);
HALT
end;
PROCEDURE PRINTERROR ;
VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,F,K: INTEGER;
BEGIN
IF NOT LIST THEN
BEGIN
IF MARGIN THEN WRITE(OUTPUT, SEQFLD:9) ELSE WRITELN(OUTPUT,LINECOUNT:9) ;
WRITELN(OUTPUT, ' ':13, LINEBUF:80) ;
END ;
(*OUTPUT ERROR MESSAGES*)
WRITE(OUTPUT,'****':12, ' ':10) ;
LASTPOS := 0; FREEPOS := 1;
FOR K := 1 TO ERRINX DO
BEGIN
WITH ERRLIST[K] DO
BEGIN CURRPOS := POS; CURRNMR := NMR END;
IF CURRPOS = LASTPOS THEN WRITE(OUTPUT,',')
ELSE
BEGIN
WHILE FREEPOS < CURRPOS DO
BEGIN WRITE(OUTPUT,' '); FREEPOS := FREEPOS + 1 END;
WRITE(OUTPUT,'↑');
LASTPOS := CURRPOS
END;
IF CURRNMR < 10 THEN F := 1
ELSE IF CURRNMR < 100 THEN F := 2
ELSE F := 3;
WRITE(OUTPUT,CURRNMR:F);
FREEPOS := FREEPOS + F + 1
END;
WRITELN(OUTPUT); ERRINX := 0 ; PRCODE := FALSE ;
END (*PRINTERROR*) ;
PROCEDURE ENDOFLINE ;
VAR I: 0..81 ;
BEGIN IF ERRINX > 0 THEN PRINTERROR ;
for I := 1 to 81 do LINEBUF[I] := ' ';
I := 0;
while (I < 81) and not EOLN(INPUT) do
begin
I := I + 1;
READ(INPUT,LINEBUF[I])
end;
READLN(INPUT);
(* READ(INPUT,LINEBUF) *) ; LINEBUF[81] := '#' ;
IF MARGIN THEN
FOR I := 1 TO 8 DO
BEGIN SEQFLD[I] := LINEBUF[72+I] ; LINEBUF[72+I] := ' ' END ;
LINECOUNT := LINECOUNT+1 ;
IF LIST THEN
BEGIN
IF MARGIN THEN WRITE(OUTPUT, SEQFLD:9)
ELSE WRITE(OUTPUT,LINECOUNT: 9) ;
IF DP THEN WRITE(OUTPUT,LC:8) ELSE WRITE(OUTPUT,IC:8);
WRITE(OUTPUT,LEVEL:3,') ') ;
% IF MARGIN THEN WRITELN(OUTPUT, LINEBUF: 72)
ELSE \ WRITELN(OUTPUT, LINEBUF:80) ;
END;
CHCNT := 0
END (*ENDOFLINE*) ;
PROCEDURE ERROR(FERRNR: INTEGER);
BEGIN
IF ERRINX >= 9 THEN
BEGIN ERRLIST[10].NMR := 255; ERRINX := 10 END
ELSE
BEGIN ERRINX := ERRINX + 1;
ERRLIST[ERRINX].NMR := FERRNR
END;
ERRLIST[ERRINX].POS := CHCNT ;
ERRORCOUNT := ERRORCOUNT+1 ;
END (*ERROR*) ;
PROCEDURE INSYMBOL;
(*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LNGTH*)
LABEL 1,2,3;
VAR I,K: INTEGER;
DIGIT: PACKED ARRAY [1..REALLNGTH] OF CHAR;
STRING: PACKED ARRAY [1..STRGLNGTH] OF CHAR;
LVP: CSP;TEST: BOOLEAN;
PROCEDURE SKIPBLNK;
(* SKIP BLANKS, ENDOFLINE, AND (OPTIONAL) MARGIN, SKIPS AT LEAST ONE CHAR *)
BEGIN
REPEAT
IF EOL THEN
BEGIN
IF EOF(INPUT) THEN
BEGIN WRITELN(OUTPUT,'**** EOF ENCOUNTERED':24) ;
EXITT(ERRORCOUNT+1) ;
END ;
ENDOFLINE ;
END ;
REPEAT CHCNT := CHCNT+1 ; UNTIL LINEBUF[CHCNT] <> ' ' ;
(* NOTE THAT LINEBUF[81] <> ' ' *)
% IF MARGIN THEN EOL := CHCNT >= 73
ELSE \ EOL := CHCNT >= 81 ;
UNTIL NOT EOL ;
CH := LINEBUF[CHCNT] ;
END (*SKIPBLNK*) ;
PROCEDURE NEXTCH;
BEGIN
REPEAT
IF EOL THEN
BEGIN
IF EOF(INPUT) THEN
BEGIN WRITELN(OUTPUT,'**** EOF ENCOUNTERED':24) ;
EXITT(ERRORCOUNT+1) ;
END ;
ENDOFLINE ;
END ;
EOL := (CHCNT = 80) ; CHCNT := CHCNT+1 ;
CH := LINEBUF[CHCNT] ;
UNTIL NOT(MARGIN AND (CHCNT > 72)) ;
END;
PROCEDURE OPTIONS;
BEGIN
REPEAT NEXTCH;
IF CH <> '*' THEN
BEGIN
IF CH = 'T' THEN
BEGIN NEXTCH; PRTABLES := CH = '+' END
ELSE
IF CH = 'L' THEN
BEGIN NEXTCH; LIST := CH = '+';
% IF NOT LIST THEN WRITELN(OUTPUT) \
END
ELSE
IF CH = 'C' THEN
BEGIN NEXTCH; PRCODE := CH = '+' END
ELSE
IF CH = 'E' THEN
BEGIN NEXTCH ;
EBCDFLG := CH = '+' ;
END
ELSE
IF CH = 'A' THEN
BEGIN NEXTCH ; ASSEMBLE := CH ='+' END
ELSE
IF CH='M' THEN
BEGIN NEXTCH ; MARGIN := CH <> '-' END
ELSE
IF CH = 'S' THEN
BEGIN NEXTCH ; SAVEREGS := CH <> '-' END
ELSE
IF CH = 'F' THEN
BEGIN NEXTCH ; SAVEFPRS := CH <> '-' ;
END
ELSE
IF CH = 'D' THEN
BEGIN NEXTCH ; DEBUG := CH <> '-' END
ELSE
IF CH = 'P' THEN
BEGIN NEXTCH ; PACKDATA := CH = '+' ;
%LCW 5JUN78 NONSENSE ON S1 IF PACKDATA THEN MXDATASZE := INTSIZE \
%LCW 5JUN78 NONSENSE ON S1 ELSE MXDATASZE := REALSIZE; \
END
ELSE
IF CH = 'B' THEN
BEGIN NEXTCH ; BYTEON := CH = '+' ;
DEBUG := BYTEON ;
END
ELSE
IF CH = 'V' THEN
BEGIN NEXTCH ; ASMVERB := CH ='+' END
ELSE
IF CH = 'U' THEN
BEGIN NEXTCH ; GET←STAT := CH = '+' END
ELSE IF CH = 'K' THEN
BEGIN NEXTCH;
%CTR\ CTROPTION := CH = '+' ;
%CTR\ IF CTROPTION THEN REWRITE(QRD) ;
END ;
NEXTCH
END
UNTIL CH <> ','
END (*OPTIONS*) ;
BEGIN (*INSYMBOL*)
1:
% REPEAT WHILE (CH = ' ') AND NOT EOL DO NEXTCH;
TEST := EOL;
IF TEST THEN NEXTCH
UNTIL NOT TEST; \
IF CH = ' ' THEN SKIPBLNK ;
CASE CH OF
'A','B','C','D','E','F','G','H','I',
'J','K','L','M','N','O','P','Q','R',
'S','T','U','V','W','X','Y','Z':
BEGIN K := 0 ; ID := BLANK12 ;
REPEAT
IF K < IDLNGTH THEN
BEGIN K := K + 1; ID[K] := CH END ;
NEXTCH
UNTIL NOT(CH IN ALPHANUMERIC) ;
% IF K >= KK THEN KK := K
ELSE
REPEAT ID[KK] := ' '; KK := KK - 1
UNTIL KK = K; \
FOR I := FRW[K] TO FRW[K+1] - 1 DO
IF RW[I] = ID THEN
BEGIN SY := RSY[I]; OP := ROP[I]; GOTO 2 END;
SY := IDENT; OP := NOOP;
2: END;
'0','1','2','3','4','5','6','7','8','9':
BEGIN OP := NOOP; I := 0;
REPEAT I := I+1; IF I<= DIGMAX THEN DIGIT[I] := CH; NEXTCH
UNTIL NOT (CH IN NUMERIC) ;
IF (CH = '.') OR (CH = 'E') THEN
BEGIN
K := I;
IF CH = '.' THEN
BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH;
NEXTCH; IF CH = '.' THEN BEGIN CH := ':'; GOTO 3 END;
IF NOT (CH IN NUMERIC) THEN
ERROR(201)
ELSE
REPEAT K := K + 1;
IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH
UNTIL NOT (CH IN NUMERIC)
END;
IF CH = 'E' THEN
BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH;
NEXTCH;
IF (CH = '+') OR (CH ='-') THEN
BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH;
NEXTCH
END;
IF NOT (CH IN NUMERIC) THEN
ERROR(201)
ELSE
REPEAT K := K+1;
IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH
UNTIL NOT (CH IN NUMERIC)
END;
NEW(LVP,REEL); SY:= REALCONST; %LVP↑.CCLASS := REEL;\
WITH LVP↑ DO
BEGIN FOR I := 1 TO REALLNGTH DO RVAL[I] := ' ';
IF K <= DIGMAX THEN
FOR I := 2 TO K + 1 DO RVAL[I] := DIGIT[I-1]
ELSE BEGIN ERROR(203); RVAL[2] := '0';
RVAL[3] := '.'; RVAL[4] := '0'
END
END;
VAL.VALP := LVP
END
ELSE
3: BEGIN
IF I > DIGMAX THEN BEGIN ERROR(203); VAL.IVAL := 0 END
ELSE
WITH VAL DO
BEGIN IVAL := 0;
FOR K := 1 TO I DO
BEGIN
IF IVAL <= MXINT10 THEN
IVAL := IVAL*10 + (ORD(DIGIT[K])-ORD('0'))
ELSE BEGIN ERROR(203); IVAL := 0 END
END;
SY := INTCONST
END
END
END;
'''':
BEGIN LNGTH := 0; SY := STRINGCONST; OP := NOOP;
REPEAT
REPEAT NEXTCH; LNGTH := LNGTH + 1;
IF LNGTH <= STRGLNGTH THEN STRING[LNGTH] := CH
UNTIL (EOL) OR (CH = '''');
IF EOL THEN ERROR(202) ELSE NEXTCH
UNTIL CH <> '''';
LNGTH := LNGTH - 1; (*NOW LNGTH = NR OF CHARS IN STRING*)
IF LNGTH = 1 THEN VAL.IVAL := ORD(STRING[1])
ELSE
BEGIN NEW(LVP,STRG); %LVP↑.CCLASS:=STRG;\
IF LNGTH > STRGLNGTH THEN
BEGIN ERROR(398); LNGTH := STRGLNGTH END;
WITH LVP↑ DO
BEGIN SLNGTH := LNGTH;
FOR I := 1 TO LNGTH DO SVAL[I] := STRING[I]
END;
VAL.VALP := LVP
END
END;
':':
BEGIN OP := NOOP; NEXTCH;
IF CH = '=' THEN
BEGIN SY := BECOMES; NEXTCH END
ELSE SY := COLON
END;
'.':
BEGIN OP := NOOP; NEXTCH;
IF CH = '.' THEN
BEGIN SY := COLON; NEXTCH END
ELSE SY := PERIOD
END;
'<':
BEGIN NEXTCH; SY := RELOP;
IF CH = '=' THEN
BEGIN OP := LEOP; NEXTCH END
ELSE
IF CH = '>' THEN
BEGIN OP := NEOP; NEXTCH END
ELSE OP := LTOP
END;
'>':
BEGIN NEXTCH; SY := RELOP;
IF CH = '=' THEN
BEGIN OP := GEOP; NEXTCH END
ELSE OP := GTOP
END;
'(':
BEGIN NEXTCH;
IF CH = '*' THEN
BEGIN NEXTCH;
IF CH = '$' THEN OPTIONS;
REPEAT
WHILE CH <> '*' DO NEXTCH;
NEXTCH
UNTIL CH = ')';
NEXTCH; GOTO 1
END ;
IF CH = '/' THEN
BEGIN SY := LBRACK ; OP := NOOP ;
NEXTCH
END
ELSE BEGIN SY := LPARENT; OP := NOOP END
END;
(*EJG 12FEB78 : *)
(**) '[',']',
'*','+','-','%',
'=','/',')','&','|',
'!','?',',',';','↑','$':
BEGIN SY := SSY[CH]; OP := SOP[CH];
IF CH = '/' THEN
BEGIN NEXTCH ;
IF CH =')' THEN
BEGIN SY := RBRACK ; OP := NOOP ;
NEXTCH ;
END
END
ELSE NEXTCH
END;
'"':
BEGIN REPEAT NEXTCH UNTIL CH = '"' ;
NEXTCH ; GOTO 1 ;
END ;
'#':
BEGIN NEXTCH ; GOTO 1 END ;
'←':
BEGIN SY := OTHERSY; OP := NOOP; ERROR(398) ; NEXTCH END
END (*CASE*)
END (*INSYMBOL*) ;
PROCEDURE ENTERID(FCP: CTP);
(*ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE*)
VAR NAM: ALPHA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
BEGIN NAM := FCP↑.NAME;
LCP := DISPLAY[TOP].FNAME;
IF LCP = NIL THEN
DISPLAY[TOP].FNAME := FCP
ELSE
BEGIN
REPEAT LCP1 := LCP;
IF LCP↑.NAME = NAM THEN (*NAME CONFLICT, FOLLOW RIGHT LINK*)
BEGIN ERROR(101); LCP := LCP↑.RLINK; LLEFT := FALSE END
ELSE
IF LCP↑.NAME < NAM THEN
BEGIN LCP := LCP↑.RLINK; LLEFT := FALSE END
ELSE BEGIN LCP := LCP↑.LLINK; LLEFT := TRUE END
UNTIL LCP = NIL;
IF LLEFT THEN LCP1↑.LLINK := FCP ELSE LCP1↑.RLINK := FCP
END;
FCP↑.LLINK := NIL; FCP↑.RLINK := NIL
END (*ENTERID*) ;
PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
(*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR*)
LABEL 1;
BEGIN
WHILE FCP <> NIL DO
IF FCP↑.NAME = ID THEN GOTO 1
ELSE IF FCP↑.NAME < ID THEN FCP := FCP↑.RLINK
ELSE FCP := FCP↑.LLINK;
1: FCP1 := FCP
END (*SEARCHSECTION*) ;
PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
LABEL 1;
VAR LCP: CTP;
BEGIN
FOR DISX := TOP DOWNTO 0 DO
BEGIN LCP := DISPLAY[DISX].FNAME;
WHILE LCP <> NIL DO
IF LCP↑.NAME = ID THEN
IF LCP↑.KLASS IN FIDCLS THEN GOTO 1
ELSE
BEGIN IF PRTERR THEN ERROR(103);
LCP := LCP↑.RLINK
END
ELSE
IF LCP↑.NAME < ID THEN
LCP := LCP↑.RLINK
ELSE LCP := LCP↑.LLINK
END;
(*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE*)
IF PRTERR THEN
BEGIN ERROR(104);
(*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL*)
IF TYPES IN FIDCLS THEN LCP := UTYPPTR
ELSE
IF VARS IN FIDCLS THEN LCP := UVARPTR
ELSE
IF FIELD IN FIDCLS THEN LCP := UFLDPTR
ELSE
IF KONST IN FIDCLS THEN LCP := UCSTPTR
ELSE
IF PROC IN FIDCLS THEN LCP := UPRCPTR
ELSE LCP := UFCTPTR;
END;
1: FCP := LCP
END (*SEARCHID*) ;
PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
(*ASSUME (FSP <> NIL) AND (FSP↑.FORM <= SUBRANGE) AND (FSP <> INTPTR)
AND NOT COMPTYPES(REALPTR,FSP)*)
BEGIN
WITH FSP↑ DO
IF FORM = SUBRANGE THEN
BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END
ELSE
BEGIN FMIN := 0;
IF FSP = CHARPTR THEN IF BYTEON THEN FMAX := 255 ELSE FMAX := 63
ELSE
IF (FORM = SCALAR) AND (FSP↑.FCONST <> NIL) THEN
FMAX := FSP↑.FCONST↑.VALUES.IVAL
ELSE FMAX := 0
END
END (*GETBOUNDS*) ;
% PROCEDURE PRINTTABLES(FB: BOOLEAN);
"*PRINT DATA STRUCTURE AND NAME TABLE*"
VAR I, LIM: DISPRANGE;
PROCEDURE MARKER;
"*MARK DATA STRUCTURE ENTRIES TO AVOID MULTIPLE PRINTOUT*"
VAR I: INTEGER;
PROCEDURE MARKCTP(FP: CTP); FORWARD;
PROCEDURE MARKSTP(FP: STP);
"*MARK DATA STRUCTURES, PREVENT CYCLES*"
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
BEGIN MARKED := TRUE;
CASE FORM OF
SCALAR: ;
SUBRANGE: MARKSTP(RANGETYPE);
POINTER: "*DON'T MARK ELTYPE: CYCLE POSSIBLE; WILL BE MARKED
ANYWAY, IF FP = TRUE*" ;
POWER: MARKSTP(ELSET) ;
ARRAYS: BEGIN MARKSTP(AELTYPE); MARKSTP(INXTYPE) END;
RECORDS: BEGIN MARKCTP(FSTFLD); MARKSTP(RECVAR) END;
FILES: MARKSTP(FILTYPE);
TAGFLD: MARKSTP(FSTVAR);
VARIANT: BEGIN MARKSTP(NXTVAR); MARKSTP(SUBVAR) END
END "*CASE*"
END "*WITH*"
END "*MARKSTP*";
PROCEDURE MARKCTP;
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
BEGIN MARKCTP(LLINK); MARKCTP(RLINK);
MARKSTP(IDTYPE)
END
END "*MARKCTP*";
BEGIN "*MARK*"
FOR I := TOP DOWNTO LIM DO
MARKCTP(DISPLAY[I].FNAME)
END "*MARK*";
PROCEDURE FOLLOWCTP(FP: CTP); FORWARD;
PROCEDURE FOLLOWSTP(FP: STP);
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
IF MARKED THEN
BEGIN MARKED := FALSE; WRITE(OUTPUT,' ':4,ORD(FP):6,SIZE:10);
CASE FORM OF
SCALAR: BEGIN WRITE(OUTPUT,'SCALAR':10);
IF SCALKIND = STANDARD THEN
WRITE(OUTPUT,'STANDARD ':10)
ELSE WRITE(OUTPUT,'DECLARED ':10, ORD(FCONST):8);
WRITELN(OUTPUT)
END;
SUBRANGE:BEGIN
WRITE(OUTPUT,'SUBRANGE ':10,' ':4,ORD(RANGETYPE):6);
IF RANGETYPE <> REALPTR THEN
WRITE(OUTPUT,MIN.IVAL,MAX.IVAL)
ELSE
IF (MIN.VALP <> NIL) AND (MAX.VALP <> NIL) THEN
WRITE(OUTPUT,' ',MIN.VALP↑.RVAL:9,
' ',MAX.VALP↑.RVAL:9);
WRITELN(OUTPUT); FOLLOWSTP(RANGETYPE);
END;
POINTER: WRITELN(OUTPUT,'POINTER':10,' ':4,ORD(ELTYPE):6);
POWER: BEGIN WRITELN(OUTPUT,'SET':10,' ':4,ORD(ELSET):6);
FOLLOWSTP(ELSET)
END;
ARRAYS: BEGIN
WRITELN(OUTPUT,'ARRAY':10,' ':4,ORD(AELTYPE):6,' ':4,
ORD(INXTYPE):6);
FOLLOWSTP(AELTYPE); FOLLOWSTP(INXTYPE)
END;
RECORDS: BEGIN
WRITELN(OUTPUT,'RECORD':10,' ':4,ORD(FSTFLD):6,' ':4,
ORD(RECVAR):6); FOLLOWCTP(FSTFLD);
FOLLOWSTP(RECVAR)
END;
FILES: BEGIN WRITE(OUTPUT,'FILE':10,' ':4,ORD(FILTYPE):6);
FOLLOWSTP(FILTYPE)
END;
TAGFLD: BEGIN WRITELN(OUTPUT,'TAGFLD':10,' ':4,ORD(TAGFIELDP):6,
' ':4,ORD(FSTVAR):6);
FOLLOWSTP(FSTVAR)
END;
VARIANT: BEGIN WRITELN(OUTPUT,'VARIANT':10,' ':4,ORD(NXTVAR):6,
' ':4,ORD(SUBVAR):6,VARVAL.IVAL);
FOLLOWSTP(NXTVAR); FOLLOWSTP(SUBVAR)
END
END "*CASE*"
END "*IF MARKED*"
END "*FOLLOWSTP*";
PROCEDURE FOLLOWCTP;
VAR I: INTEGER;
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
BEGIN WRITE(OUTPUT,' ':4,ORD(FP):6,' ',NAME:9,' ':4,ORD(LLINK):6,
' ':4,ORD(RLINK):6,' ':4,ORD(IDTYPE):6);
CASE KLASS OF
TYPES: WRITE(OUTPUT,'TYPE':10);
KONST: BEGIN WRITE(OUTPUT,'CONSTANT ':10,' ':4,ORD(NEXT):6);
IF IDTYPE <> NIL THEN
IF IDTYPE = REALPTR THEN
BEGIN
IF VALUES.VALP <> NIL THEN
WRITE(OUTPUT,' ',VALUES.VALP↑.RVAL:9)
END
ELSE
IF IDTYPE↑.FORM = ARRAYS THEN "*STRINGCONST*"
BEGIN
IF VALUES.VALP <> NIL THEN
BEGIN WRITE(OUTPUT,' ');
WITH VALUES.VALP↑ DO
FOR I := 1 TO SLNGTH DO
WRITE(OUTPUT,SVAL[I])
END
END
ELSE WRITE(OUTPUT,VALUES.IVAL)
END;
VARS: BEGIN WRITE(OUTPUT,'VARIABLE ':10);
IF VKIND = ACTUAL THEN WRITE(OUTPUT,'ACTUAL':10)
ELSE WRITE(OUTPUT,'FORMAL':10);
WRITE(OUTPUT,' ':4,ORD(NEXT):6,VLEV,' ':4,VADDR:6 );
END;
FIELD: WRITE(OUTPUT,'FIELD':10,' ':4,ORD(NEXT):6,' ':4,FLDADDR:6);
PROC,
FUNC: BEGIN
IF KLASS = PROC THEN WRITE(OUTPUT,'PROCEDURE':10)
ELSE WRITE(OUTPUT,'FUNCTION ':10);
IF PFDECKIND = STANDARD THEN
WRITE(OUTPUT,'STANDARD ':10,
KEY:10)
ELSE
BEGIN WRITE(OUTPUT,'DECLARED ':10, ORD(NEXT):8);
WRITE(OUTPUT,PFLEV,' ':4,PFNAME:6);
IF PFKIND = ACTUAL THEN
BEGIN WRITE(OUTPUT,'ACTUAL':10);
IF FORWDECL THEN WRITE(OUTPUT,'FORWARD':10)
ELSE WRITE(OUTPUT,'NOTFORWARD':10);
IF XTERN THEN WRITE(OUTPUT,'EXTERN':10)
ELSE WRITE(OUTPUT,'NOT EXTERN':10);
END
ELSE WRITE(OUTPUT,'FORMAL':10)
END
END
END "*CASE*";
WRITELN(OUTPUT); FOLLOWCTP(LLINK); FOLLOWCTP(RLINK);
FOLLOWSTP(IDTYPE)
END "*WITH*"
END "*FOLLOWCTP*";
BEGIN "*PRINTTABLES*"
WRITELN(OUTPUT); WRITELN(OUTPUT); WRITELN(OUTPUT);
IF FB THEN LIM := 0
ELSE BEGIN LIM := TOP; WRITE(OUTPUT,' LOCAL') END;
WRITELN(OUTPUT,' TABLES '); WRITELN(OUTPUT);
MARKER;
FOR I := TOP DOWNTO LIM DO
FOLLOWCTP(DISPLAY[I].FNAME);
WRITELN(OUTPUT);
IF NOT EOL THEN WRITE(OUTPUT,' ':CHCNT+16)
END "*PRINTTABLES*"; \
PROCEDURE GENLABEL(VAR NXTLAB: INTEGER);
BEGIN INTLABEL := INTLABEL + 1;
NXTLAB := INTLABEL
END (*GENLABEL*);
PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP);
VAR LSY: SYMBOL; TEST: BOOLEAN; SEGSIZE: INTEGER ;
PROCEDURE SKIP(FSYS: SETOFSYS);
(*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*)
BEGIN
WHILE NOT(SY IN FSYS) DO
BEGIN
INSYMBOL
END ;
END (*SKIP*) ;
PROCEDURE ALIGN(VAR Q:ADDRRANGE; P: ADDRRANGE) ;
VAR I : INTEGER ;
BEGIN
IF P >= MXDATASZE THEN P := MXDATASZE %LCW 5JUN78\
ELSE IF P >= INTSIZE THEN P := INTSIZE
ELSE IF P <= 0 THEN IF ERRORCOUNT = 0 THEN ERROR(500) ;
IF P >= INTSIZE THEN
BEGIN I:= Q MOD P ; IF I > 0 THEN Q := Q+(P-I) END ;
END (*ALIGN*) ;
PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
LVP: CSP; I: 2..REALLNGTH;
BEGIN LSP := NIL; FVALU.IVAL := 0;
IF NOT(SY IN CONSTBEGSYS) THEN
BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END;
IF SY IN CONSTBEGSYS THEN
BEGIN
IF SY = STRINGCONST THEN
BEGIN
IF LNGTH = 1 THEN LSP := CHARPTR
ELSE
BEGIN
NEW(LSP,ARRAYS);
WITH LSP↑ DO
BEGIN AELTYPE := CHARPTR; INXTYPE := NIL;
SIZE := LNGTH*CHARSIZE; FORM := ARRAYS
END
END;
FVALU := VAL; INSYMBOL
END
ELSE
BEGIN
SIGN := NONE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN
BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG;
INSYMBOL
END;
IF SY = IDENT THEN
BEGIN SEARCHID([KONST],LCP);
WITH LCP↑ DO
BEGIN LSP := IDTYPE; FVALU := VALUES END;
IF SIGN <> NONE THEN
IF LSP = INTPTR THEN
BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END
ELSE
IF LSP = REALPTR THEN
BEGIN
IF SIGN = NEG THEN
BEGIN NEW(LVP,REEL);
IF FVALU.VALP↑.RVAL[1] = '-' THEN
LVP↑.RVAL[1] := '+'
ELSE LVP↑.RVAL[1] := '-';
FOR I := 2 TO REALLNGTH DO
LVP↑.RVAL[I] := FVALU.VALP↑.RVAL[I];
FVALU.VALP := LVP;
END
END
ELSE ERROR(105);
INSYMBOL;
END
ELSE
IF SY = INTCONST THEN
BEGIN IF SIGN = NEG THEN VAL.IVAL := -VAL.IVAL;
LSP := INTPTR; FVALU := VAL; INSYMBOL
END
ELSE
IF SY = REALCONST THEN
BEGIN IF SIGN = NEG THEN VAL.VALP↑.RVAL[1] := '-';
LSP := REALPTR; FVALU := VAL; INSYMBOL
END
ELSE
BEGIN ERROR(106); SKIP(FSYS) END
END;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END;
FSP := LSP
END (*CONSTANT*) ;
FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR NXT1,NXT2: CTP; COMP: BOOLEAN;
LTESTP1,LTESTP2 : TESTP;
BEGIN
IF FSP1 = FSP2 THEN COMPTYPES := TRUE
ELSE
IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN
IF FSP1↑.FORM = FSP2↑.FORM THEN
CASE FSP1↑.FORM OF
SCALAR:
COMPTYPES := FALSE;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
SUBRANGE:
COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2↑.RANGETYPE);
POINTER:
BEGIN
COMP := FALSE; LTESTP1 := GLOBTESTP;
LTESTP2 := GLOBTESTP;
WHILE LTESTP1 <> NIL DO
WITH LTESTP1↑ DO
BEGIN
IF (ELT1 = FSP1↑.ELTYPE) AND
(ELT2 = FSP2↑.ELTYPE) THEN COMP := TRUE;
LTESTP1 := LASTTESTP
END;
IF NOT COMP THEN
BEGIN NEW(LTESTP1);
WITH LTESTP1↑ DO
BEGIN ELT1 := FSP1↑.ELTYPE;
ELT2 := FSP2↑.ELTYPE;
LASTTESTP := GLOBTESTP
END;
GLOBTESTP := LTESTP1;
COMP := COMPTYPES(FSP1↑.ELTYPE,FSP2↑.ELTYPE)
END;
COMPTYPES := COMP; GLOBTESTP := LTESTP2
END;
POWER:
COMPTYPES := COMPTYPES(FSP1↑.ELSET,FSP2↑.ELSET);
ARRAYS:
COMPTYPES := COMPTYPES(FSP1↑.AELTYPE,FSP2↑.AELTYPE)
AND (FSP1↑.SIZE = FSP2↑.SIZE);
(*ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
BE COMPATIBLE.
-- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
BE THE SAME*)
RECORDS:
BEGIN NXT1 := FSP1↑.FSTFLD; NXT2 := FSP2↑.FSTFLD; COMP:=TRUE;
WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
BEGIN COMP:=COMP AND COMPTYPES(NXT1↑.IDTYPE,NXT2↑.IDTYPE);
NXT1 := NXT1↑.NEXT; NXT2 := NXT2↑.NEXT
END;
COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
AND(FSP1↑.RECVAR = NIL)AND(FSP2↑.RECVAR = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IFF NO VARIANTS OCCUR*)
FILES:
COMPTYPES := COMPTYPES(FSP1↑.FILTYPE,FSP2↑.FILTYPE)
END (*CASE*)
ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
IF FSP1↑.FORM = SUBRANGE THEN
COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2)
ELSE
IF FSP2↑.FORM = SUBRANGE THEN
COMPTYPES := COMPTYPES(FSP1,FSP2↑.RANGETYPE)
ELSE COMPTYPES := FALSE
ELSE COMPTYPES := TRUE
END (*COMPTYPES*) ;
FUNCTION STRING(FSP: STP) : BOOLEAN;
BEGIN STRING := FALSE;
IF FSP <> NIL THEN
IF FSP↑.FORM = ARRAYS THEN
STRING := COMPTYPES(FSP↑.AELTYPE,CHARPTR)
END (*STRING*) ;
PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE);
VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
LSIZE,DISPL: ADDRRANGE; LMIN,LMAX: INTEGER; ALNFCT : 1..8 ;
PROCEDURE SIMPLETYPE(FSYS:SETOFSYS; VAR FSP:STP%; VAR FSIZE:ADDRRANGE\);
VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
LCNT: INTEGER; LVALU: VALU;
BEGIN FSIZE := 1;
IF NOT (SY IN SIMPTYPEBEGSYS) THEN
BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END;
IF SY IN SIMPTYPEBEGSYS THEN
BEGIN
IF SY = LPARENT THEN
BEGIN TTOP := TOP; (*DECL. CONSTS LOCAL TO INNERMOST BLOCK*)
WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1;
NEW(LSP,SCALAR,DECLARED);
WITH LSP↑ DO
BEGIN SIZE := INTSIZE; FORM := SCALAR;
SCALKIND := DECLARED
END;
LCP1 := NIL; LCNT := 0;
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,KONST);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := LSP; NEXT := LCP1;
VALUES.IVAL := LCNT; KLASS := KONST
END;
ENTERID(LCP);
LCNT := LCNT + 1;
LCP1 := LCP; INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END
UNTIL SY <> COMMA;
IF PACKDATA THEN
IF LCNT < 256 THEN LSP↑.SIZE := CHARSIZE ;
LSP↑.ALN := LSP↑.SIZE ;
LSP↑.FCONST := LCP1; TOP := TTOP;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END
ELSE
BEGIN
IF SY = IDENT THEN
BEGIN SEARCHID([TYPES,KONST],LCP);
INSYMBOL;
IF LCP↑.KLASS = KONST THEN
BEGIN NEW(LSP,SUBRANGE);
WITH LSP↑, LCP↑ DO
BEGIN RANGETYPE := IDTYPE; FORM := SUBRANGE;
IF STRING(RANGETYPE) THEN
BEGIN ERROR(148); RANGETYPE := NIL END;
MIN := VALUES; SIZE := IDTYPE↑.SIZE
END;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
CONSTANT(FSYS,LSP1,LVALU);
LSP↑.MAX := LVALU;
IF PACKDATA THEN
IF LVALU.IVAL < 256 THEN
IF LSP↑.MIN.IVAL >= 0 THEN LSP↑.SIZE := CHARSIZE ;
LSP↑.ALN := LSP↑.SIZE ;
IF LSP↑.RANGETYPE <> LSP1 THEN ERROR(107)
END
ELSE
BEGIN LSP := LCP↑.IDTYPE;
% IF LSP <> NIL THEN FSIZE := LSP↑.SIZE \
END
END (*SY = IDENT*)
ELSE
BEGIN NEW(LSP,SUBRANGE); LSP↑.FORM := SUBRANGE;
CONSTANT(FSYS + [COLON],LSP1,LVALU);
IF STRING(LSP1) THEN
BEGIN ERROR(148); LSP1 := NIL END;
WITH LSP↑ DO
BEGIN RANGETYPE:=LSP1; MIN:=LVALU; SIZE:=INTSIZE;
IF LSP1 <> NIL THEN SIZE := LSP1↑.SIZE ;
END;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
CONSTANT(FSYS,LSP1,LVALU);
LSP↑.MAX := LVALU;
IF PACKDATA THEN
IF LVALU.IVAL < 256 THEN
IF LSP↑.MIN.IVAL >= 0 THEN LSP↑.SIZE := CHARSIZE ;
LSP↑.ALN := LSP↑.SIZE ;
IF LSP↑.RANGETYPE <> LSP1 THEN ERROR(107)
END;
IF LSP <> NIL THEN
WITH LSP↑ DO
IF FORM = SUBRANGE THEN
IF RANGETYPE <> NIL THEN
IF RANGETYPE = REALPTR THEN ERROR(398)
ELSE
IF MIN.IVAL > MAX.IVAL THEN ERROR(102)
END;
FSP := LSP;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE FSP := NIL
END (*SIMPLETYPE*) ;
PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP;VAR RECALN: ALNRNG);
VAR LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP;
MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU; LALNFCT : ALNRNG ;
BEGIN NXT1 := NIL; LSP := NIL; RECALN := 1 ;
IF NOT (SY IN FSYS+[IDENT,CASESY]) THEN
BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END;
WHILE SY = IDENT DO
BEGIN NXT := NXT1;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,FIELD);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := NXT;
KLASS := FIELD
END;
NXT := LCP;
ENTERID(LCP);
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN [COMMA,COLON]) THEN
BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY])
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE);
LALNFCT := 1 ; IF LSP <> NIL THEN LALNFCT := LSP↑.ALN ;
WHILE NXT <> NXT1 DO
WITH NXT↑ DO
BEGIN IDTYPE := LSP; ALIGN(DISPL,LALNFCT) ; FLDADDR := DISPL;
NXT := NEXT; DISPL := DISPL + LSIZE
END;
IF LALNFCT > RECALN THEN RECALN := LSP↑.ALN ;
NXT1 := LCP;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN [IDENT,CASESY,ENDSY]) THEN (* IGNOR EXTRA ; *)
BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END
END
END (*WHILE*);
NXT := NIL;
WHILE NXT1 <> NIL DO
WITH NXT1↑ DO
BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END;
IF SY = CASESY THEN
BEGIN NEW(LSP,TAGFLD);
WITH LSP↑ DO
BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM:=TAGFLD END;
FRECVAR := LSP;
INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,FIELD);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; KLASS:=FIELD;
NEXT := NIL ; (*FLDADDR WILL BE SET WHEN TYPE IS KNOWN*)
END;
%TAG\ PRTERR := FALSE ; SEARCHID([TYPES],LCP1) ; PRTERR := TRUE ;
%TAG\ IF LCP1 = NIL THEN BEGIN (*EXPLICIT TAG FIELD *)
ENTERID(LCP); INSYMBOL ;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END
%TAG\ ; END (* IF LCP1 = NIL *)
ELSE (* NO EXPLICT TAG FIELD *)
%TAG\ LCP↑.NAME := BLANK12 ;
BEGIN SEARCHID([TYPES],LCP1);
LSP1 := LCP1↑.IDTYPE;
IF LSP1 <> NIL THEN
WITH LSP1↑ DO
BEGIN
%TAG\ IF LCP↑.NAME <> BLANK12 THEN BEGIN
ALIGN(DISPL,ALN) ;
IF ALN > RECALN THEN RECALN := ALN ;
LCP↑.FLDADDR := DISPL ; DISPL := DISPL + SIZE;
%TAG\ END (* LCP↑.NAME <> BLANK12 *) ;
IF (FORM <= SUBRANGE) OR STRING(LSP1) THEN
BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109)
ELSE IF STRING(LSP1) THEN ERROR(398);
LCP↑.IDTYPE := LSP1; LSP↑.TAGFIELDP := LCP;
END
ELSE ERROR(110);
END (* WITH LSP1↑ DO *) ;
INSYMBOL;
END
END
ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END;
LSP↑.SIZE := DISPL;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL;
REPEAT LSP2 := NIL;
REPEAT CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP3,LVALU);
IF LSP↑.TAGFIELDP <> NIL THEN
IF NOT COMPTYPES(LSP↑.TAGFIELDP↑.IDTYPE,LSP3)THEN ERROR(111);
NEW(LSP3,VARIANT);
WITH LSP3↑ DO
BEGIN NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
FORM := VARIANT
END;
LSP1 := LSP3; LSP2 := LSP3;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2,LALNFCT);
IF LALNFCT > RECALN THEN RECALN := LALNFCT ;
IF DISPL > MAXSIZE THEN MAXSIZE := DISPL;
WHILE LSP3 <> NIL DO
BEGIN LSP4 := LSP3↑.SUBVAR; LSP3↑.SUBVAR := LSP2;
LSP3↑.SIZE := DISPL;
LSP3 := LSP4
END;
IF SY = RPARENT THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [SEMICOLON]) THEN
BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END
END
ELSE ERROR(4);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN
BEGIN DISPL := MINSIZE;
INSYMBOL ; TEST := SY = ENDSY ; (* IGNORE EXTRA ;*)
END
UNTIL TEST;
DISPL := MAXSIZE;
LSP↑.FSTVAR := LSP1;
END
ELSE FRECVAR := NIL
END (*FIELDLIST*) ;
BEGIN (*TYP*)
IF NOT (SY IN TYPEBEGSYS) THEN
BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END;
IF SY IN TYPEBEGSYS THEN
BEGIN
IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP%,FSIZE\)
ELSE
(*↑*) IF SY = ARROW THEN
BEGIN NEW(LSP,POINTER); FSP := LSP;
WITH LSP↑ DO
BEGIN ELTYPE := NIL;
SIZE := PTRSIZE; ALN := PTRSIZE ; FORM:=POINTER
END;
INSYMBOL;
IF SY = IDENT THEN
BEGIN PRTERR := FALSE; (*NO ERROR IF SEARCH NOT SUCCESSFUL*)
SEARCHID([TYPES],LCP); PRTERR := TRUE;
IF LCP = NIL THEN (*FORWARD REFERENCED TYPE ID*)
BEGIN NEW(LCP,TYPES);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := LSP;
NEXT := FWPTR; KLASS := TYPES
END;
FWPTR := LCP
END
ELSE
BEGIN
IF LCP↑.IDTYPE <> NIL THEN
IF LCP↑.IDTYPE↑.FORM = FILES THEN ERROR(108)
ELSE LSP↑.ELTYPE := LCP↑.IDTYPE
END;
INSYMBOL;
END
ELSE ERROR(2);
END
ELSE
BEGIN
IF SY = PACKEDSY THEN
BEGIN INSYMBOL;
IF NOT (SY IN TYPEDELS) THEN
BEGIN
ERROR(10); SKIP(FSYS + TYPEDELS)
END
END;
(*ARRAY*) IF SY = ARRAYSY THEN
BEGIN INSYMBOL;
IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
LSP1 := NIL;
REPEAT NEW(LSP,ARRAYS);
WITH LSP↑ DO
BEGIN AELTYPE := LSP1; INXTYPE := NIL; FORM:=ARRAYS END;
LSP1 := LSP;
SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2%,LSIZE\);
% LSP1↑.SIZE := LSIZE ; NOT USED \
IF LSP2 <> NIL THEN
IF LSP2↑.FORM <= SUBRANGE THEN
BEGIN
IF LSP2 = REALPTR THEN
BEGIN ERROR(109); LSP2 := NIL END
ELSE
IF LSP2 = INTPTR THEN
BEGIN ERROR(149); LSP2 := NIL END;
LSP↑.INXTYPE := LSP2
END
ELSE BEGIN ERROR(113); LSP2 := NIL END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
TYP(FSYS,LSP,LSIZE); ALIGN(LSIZE,LSP↑.ALN) ;
REPEAT
WITH LSP1↑ DO
BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
IF INXTYPE <> NIL THEN
BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
LSIZE := LSIZE*(LMAX - LMIN + 1);
SIZE := LSIZE ; ALN := LSP↑.ALN (*PROPAG. ALN*) ;
END
END;
LSP := LSP1; LSP1 := LSP2
UNTIL LSP1 = NIL
END
ELSE
(*RECORD*) IF SY = RECORDSY THEN
BEGIN INSYMBOL;
OLDTOP := TOP;
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN FNAME := NIL;
FLABEL := NIL;
OCCUR := REC
END
END
ELSE ERROR(250);
DISPL := 0;
FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1,ALNFCT);
NEW(LSP,RECORDS);
WITH LSP↑ DO
BEGIN FSTFLD := DISPLAY[TOP].FNAME;
RECVAR := LSP1; SIZE := DISPL;
FORM := RECORDS ; ALN := ALNFCT ;
END;
TOP := OLDTOP;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END
ELSE
(*SET*) IF SY = SETSY THEN
BEGIN INSYMBOL;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
SIMPLETYPE(FSYS,LSP1%,LSIZE\);
IF LSP1 <> NIL THEN
IF LSP1↑.FORM > SUBRANGE THEN
BEGIN ERROR(115); LSP1 := NIL END
ELSE
IF LSP1 = REALPTR THEN ERROR(114);
NEW(LSP,POWER);
WITH LSP↑ DO
BEGIN ELSET:=LSP1;
SIZE:=SETSIZE; ALN := INTSIZE ; FORM:=POWER
END;
END
ELSE
(*FILE*) IF SY = FILESY THEN
%BEGIN ERROR(398); INSYMBOL; SKIP(FSYS); LSP:= NIL END;\
BEGIN INSYMBOL ;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8) ;
SIMPLETYPE(FSYS,LSP1%,LSIZE\) ;
IF LSP1 = NIL THEN ERROR(398)
ELSE IF LSP1 <> CHARPTR THEN ERROR(398) ;
LSP := TEXTPTR ;
END ;
FSP := LSP
END;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE FSP := NIL;
IF FSP = NIL THEN FSIZE := 1 ELSE FSIZE := FSP↑.SIZE
END (*TYP*) ;
PROCEDURE LABELDECLARATION;
VAR LLP: LBP; REDEF: BOOLEAN; LBNAME: LABELRNG ;
BEGIN
REPEAT
IF SY = INTCONST THEN
WITH DISPLAY[TOP] DO
BEGIN LLP := FLABEL; REDEF := FALSE;
WHILE (LLP <> NIL) AND NOT REDEF DO
IF LLP↑.LABVAL <> VAL.IVAL THEN
LLP := LLP↑.NEXTLAB
ELSE BEGIN REDEF := TRUE; ERROR(166) END;
IF NOT REDEF THEN
BEGIN NEW(LLP);
WITH LLP↑ DO
BEGIN LABVAL := VAL.IVAL; GENLABEL(LBNAME);
DEFINED := FALSE; NEXTLAB := FLABEL; LABNAME := LBNAME
END;
FLABEL := LLP
END;
INSYMBOL
END
ELSE ERROR(15);
IF NOT ( SY IN FSYS + [COMMA, SEMICOLON] ) THEN
BEGIN ERROR(6); SKIP(FSYS+[COMMA,SEMICOLON]) END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14)
END (* LABELDECLARATION *) ;
PROCEDURE CONSTDECLARATION;
VAR LCP: CTP; LSP: STP; LVALU: VALU;
BEGIN
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
WHILE SY = IDENT DO
BEGIN NEW(LCP,KONST);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := NIL; KLASS:=KONST END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
CONSTANT(FSYS + [SEMICOLON],LSP,LVALU);
ENTERID(LCP);
LCP↑.IDTYPE := LSP; LCP↑.VALUES := LVALU;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
END
ELSE ERROR(14)
END
END (*CONSTDECLARATION*) ;
PROCEDURE TYPEDECLARATION;
VAR LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
BEGIN
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
WHILE SY = IDENT DO
BEGIN NEW(LCP,TYPES);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; KLASS := TYPES END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
TYP(FSYS + [SEMICOLON],LSP,LSIZE);
ENTERID(LCP);
LCP↑.IDTYPE := LSP;
(*HAS ANY FORWARD REFERENCE BEEN SATISFIED:*)
LCP1 := FWPTR;
WHILE LCP1 <> NIL DO
BEGIN
IF LCP1↑.NAME = LCP↑.NAME THEN
BEGIN LCP1↑.IDTYPE↑.ELTYPE := LCP↑.IDTYPE;
IF LCP1 <> FWPTR THEN
LCP2↑.NEXT := LCP1↑.NEXT
ELSE FWPTR := LCP1↑.NEXT;
END;
LCP2 := LCP1; LCP1 := LCP1↑.NEXT
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
END
ELSE ERROR(14)
END;
IF FWPTR <> NIL THEN
BEGIN ERROR(117); WRITELN(OUTPUT);
REPEAT WRITELN(OUTPUT,' TYPE-ID ',FWPTR↑.NAME);
FWPTR := FWPTR↑.NEXT
UNTIL FWPTR = NIL;
IF NOT EOL THEN WRITE(OUTPUT,' ': CHCNT+16)
END
END (*TYPEDECLARATION*) ;
PROCEDURE VARDECLARATION;
VAR LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE; COUNT: 0..100 ;
BEGIN NXT := NIL;
REPEAT COUNT := 0 ;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,VARS); COUNT := COUNT+1 ;
WITH LCP↑ DO
BEGIN NAME := ID; NEXT := NXT; KLASS := VARS;
IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
END;
ENTERID(LCP);
NXT := LCP;
INSYMBOL;
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN
BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPEDELS) END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP,LSIZE);
ALIGN(LC,LSP↑.ALN) ;
IF LSP = TEXTPTR THEN
BEGIN
NXTFILBUF := NXTFILBUF+COUNT ; COUNT := 1 ;
IF NXTFILBUF > LASTFILBUF THEN ERROR(258) ;
END ;
WHILE NXT <> NIL DO
WITH NXT↑ DO
BEGIN IDTYPE := LSP; NXT := NEXT ;
IF LSP = TEXTPTR THEN (* TEXT FILE DECLARATION *)
BEGIN %EBCD := EBCDFLG ; EBCDFLG := FALSE ; \
VADDR := NXTFILBUF-COUNT ; VLEV := 1 ; COUNT := COUNT+1 ;
END
ELSE (* OTHER VARIABLE DECLARATION *)
BEGIN VADDR := LC ; LC := LC+LSIZE END ;
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
END
ELSE ERROR(14)
UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS);
IF FWPTR <> NIL THEN
BEGIN ERROR(117); WRITELN(OUTPUT);
REPEAT WRITELN(OUTPUT,' TYPE-ID ',FWPTR↑.NAME);
FWPTR := FWPTR↑.NEXT
UNTIL FWPTR = NIL;
IF NOT EOL THEN WRITE(OUTPUT,' ': CHCNT+16)
END ;
END (*VARDECLARATION*) ;
PROCEDURE PROCDECLARATION(FSY: SYMBOL);
VAR OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP;
FORW: BOOLEAN; OLDTOP: DISPRANGE; PARCNT: INTEGER;
LLC,LCM: ADDRRANGE; LBNAME, OLDLABEL: INTEGER; MARKP: ↑INTEGER;
PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP);
VAR LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
LLC,LEN : ADDRRANGE; COUNT : INTEGER;
BEGIN LCP1 := NIL ;
%S1\ FPRM1 := LC ; RPRM1 := 0 ; REGS←FULL := FALSE ;
IF NOT (SY IN FSY + [LPARENT]) THEN
BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END;
IF SY = LPARENT THEN
BEGIN IF FORW THEN ERROR(119);
INSYMBOL;
IF NOT (SY IN [IDENT,VARSY,PROCSY,FUNCSY]) THEN
BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END;
WHILE SY IN [IDENT,VARSY,PROCSY,FUNCSY] DO
BEGIN
IF SY = PROCSY THEN
BEGIN ERROR(398);
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,PROC,DECLARED,FORMAL);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP1;
PFLEV := LEVEL (*BEWARE OF PARAMETER PROCEDURES*);
KLASS:=PROC;PFDECKIND:=DECLARED;PFKIND:=FORMAL
END;
ENTERID(LCP);
LCP1 := LCP; LC := LC + PTRSIZE;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [COMMA,SEMICOLON,RPARENT]) THEN
BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT])END
UNTIL SY <> COMMA
END
ELSE
BEGIN
IF SY = FUNCSY THEN
BEGIN ERROR(398); LCP2 := NIL;
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,FUNC,DECLARED,FORMAL);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP2;
PFLEV := LEVEL (*BEWARE PARAM FUNCS*);
KLASS:=FUNC;PFDECKIND:=DECLARED;
PFKIND:=FORMAL
END;
ENTERID(LCP);
LCP2 := LCP; LC := LC + PTRSIZE;
INSYMBOL;
END;
IF NOT (SY IN [COMMA,COLON] + FSYS) THEN
BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT])
END
UNTIL SY <> COMMA;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN SEARCHID([TYPES],LCP);
LSP := LCP↑.IDTYPE;
IF LSP <> NIL THEN
IF NOT(LSP↑.FORM IN[SCALAR,SUBRANGE,POINTER])
THEN BEGIN ERROR(120); LSP := NIL END;
LCP3 := LCP2;
WHILE LCP2 <> NIL DO
BEGIN LCP2↑.IDTYPE := LSP; LCP := LCP2;
LCP2 := LCP2↑.NEXT
END;
LCP↑.NEXT := LCP1; LCP1 := LCP3;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN
BEGIN ERROR(7);SKIP(FSYS+[SEMICOLON,RPARENT])END
END
ELSE ERROR(5)
END
ELSE
BEGIN
IF SY = VARSY THEN
BEGIN LKIND := FORMAL; INSYMBOL END
ELSE LKIND := ACTUAL;
LCP2 := NIL;
COUNT := 0;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,VARS);
WITH LCP↑ DO
BEGIN NAME:=ID; IDTYPE:=NIL; KLASS:=VARS;
VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL;
END;
ENTERID(LCP);
LCP2 := LCP; COUNT := COUNT+1;
INSYMBOL;
END;
IF NOT (SY IN [COMMA,COLON] + FSYS) THEN
BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT])
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN SEARCHID([TYPES],LCP); LEN := PTRSIZE ;
LSP := LCP↑.IDTYPE;
IF LSP <> NIL THEN
IF (LKIND=ACTUAL) THEN
IF LSP↑.FORM <= POWER THEN LEN := LSP↑.SIZE
ELSE IF LSP↑.FORM = FILES THEN ERROR(121) ;
%S0\ % IF LSP↑.FORM = POWER THEN ALIGN(LC,4) \
%S0\ % ELSE ALIGN(LC, LEN) ; \
%S1\ ALIGN(LEN,MXDATASZE) ; ALIGN(LC,MXDATASZE) ;
LC := LC+COUNT*LEN ; LCP3 := LCP2 ; LLC := LC ;
WHILE LCP2 <> NIL DO
BEGIN LCP := LCP2;
WITH LCP2↑ DO
BEGIN IDTYPE := LSP; LLC := LLC-LEN;
VADDR := LLC;
%S1\ IF NOT REGS←FULL THEN
%S1\ IF RPRM1+LEN <= REGPRMAREA THEN
%S1\ RPRM1 := RPRM1+LEN
%S1\ ELSE REGS←FULL := TRUE ;
END;
LCP2 := LCP2↑.NEXT
END;
LCP↑.NEXT := LCP1; LCP1 := LCP3;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN
BEGIN ERROR(7);SKIP(FSYS+[SEMICOLON,RPARENT])END
END
ELSE ERROR(5);
END;
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT,VARSY,PROCSY,FUNCSY]) THEN
BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END
END
END (*WHILE*) ;
IF SY = RPARENT THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSY + FSYS) THEN
BEGIN ERROR(6); SKIP(FSY + FSYS) END
END
ELSE ERROR(4);
LCP3 := NIL;
(*REVERSE POINTERS AND RESERVE LOCAL CELLS FOR COPIES OF MULTIPLE
VALUES*)
% ALIGN(LC,MXDATASZE) ; \ (*NORMALIZE STACK BEFORE ENTRING BLOCK*)
%S1\ FPRM1 := LC-FPRM1 ; SPRM1 := LC ;
WHILE LCP1 <> NIL DO
WITH LCP1↑ DO
BEGIN LCP2 := NEXT; NEXT := LCP3;
IF KLASS = VARS THEN
IF IDTYPE <> NIL THEN
IF (VKIND = ACTUAL) AND (IDTYPE↑.FORM > POWER) THEN
BEGIN ALIGN(LC,IDTYPE↑.ALN (*OR IDTYPE↑.SIZE*) ) ;
VADDR := LC; LC := LC + IDTYPE↑.SIZE ;
END ;
LCP3 := LCP1; LCP1 := LCP2
END;
%S1\ ALIGN(LC, PTRSIZE) ; SPRM1 := LC-SPRM1 ;
FPAR := LCP3
END
ELSE
%S1\ BEGIN
FPAR := NIL ;
%S1\ FPRM1 := 0 ; SPRM1 := 0 ; RPRM1 := 0 ;
%S1\ END ;
END (*PARAMETERLIST*) ;
BEGIN (*PROCDECLARATION*)
LLC := LC; LC := LCAFTMST; (* ADR. OF THE FIRST VAR. IN THIS PROC. *)
LCP := UPRCPTR ; (* TO INITIALIZE LCP IN CASE ! *)
IF SY = IDENT THEN
BEGIN SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); (*DECIDE WHETHER FORW.*)
IF LCP <> NIL THEN
BEGIN
IF LCP↑.KLASS = PROC THEN
FORW := LCP↑.FORWDECL AND(FSY = PROCSY)AND(LCP↑.PFKIND = ACTUAL)
ELSE
IF LCP↑.KLASS = FUNC THEN
FORW:=LCP↑.FORWDECL AND(FSY=FUNCSY)AND(LCP↑.PFKIND=ACTUAL)
ELSE FORW := FALSE;
IF NOT FORW THEN ERROR(160)
END
ELSE FORW := FALSE;
IF NOT FORW THEN
BEGIN
IF FSY = PROCSY THEN NEW(LCP,PROC,DECLARED,ACTUAL)
ELSE NEW(LCP,FUNC,DECLARED,ACTUAL);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; SAVEFP := FALSE ;
XTERN := FALSE; PFLEV := LEVEL; PROCLAB := PROCLAB+1 ;
PFDECKIND := DECLARED; PFKIND := ACTUAL; PFNAME := PROCLAB ;
IF FSY = PROCSY THEN KLASS := PROC
ELSE KLASS := FUNC
END;
ENTERID(LCP)
END
ELSE
BEGIN LCP1 := LCP↑.NEXT;
WHILE LCP1 <> NIL DO
BEGIN
WITH LCP1↑ DO
IF KLASS = VARS THEN
IF IDTYPE <> NIL THEN
BEGIN LCM := VADDR + IDTYPE↑.SIZE;
IF LCM > LC THEN LC := LCM
END;
LCP1 := LCP1↑.NEXT
END
END;
INSYMBOL
END
ELSE ERROR(2);
OLDLEV := LEVEL; OLDTOP := TOP; OLDLABEL := INTLABEL ; INTLABEL := 0 ;
IF LEVEL < MAXLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(251);
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN
IF FORW THEN FNAME := LCP↑.NEXT
ELSE FNAME := NIL;
FLABEL := NIL;
OCCUR := BLCK
END
END
ELSE ERROR(250);
IF FSY = PROCSY THEN
BEGIN PARAMETERLIST([SEMICOLON],LCP1);
IF NOT FORW THEN LCP↑.NEXT := LCP1
END
ELSE
BEGIN PARAMETERLIST([SEMICOLON,COLON],LCP1);
IF NOT FORW THEN LCP↑.NEXT := LCP1;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN IF FORW THEN ERROR(122);
SEARCHID([TYPES],LCP1);
LSP := LCP1↑.IDTYPE;
LCP↑.IDTYPE := LSP;
IF LSP <> NIL THEN
BEGIN
IF NOT (LSP↑.FORM IN [SCALAR,SUBRANGE,POINTER,POWER]) THEN
BEGIN ERROR(120); LCP↑.IDTYPE := NIL END;
IF LSP = REALPTR THEN
IF SAVEFPRS THEN
BEGIN LCP1 := LCP↑.NEXT ;
WHILE LCP1 <> NIL DO
BEGIN
LCP1↑.VADDR := LCP1↑.VADDR+FPSAVEAREA ;
LCP1 := LCP1↑.NEXT ;
END ;
LCP↑.SAVEFP := TRUE ; (* SET SAVE FPRS FLAG *)
LC := LC+FPSAVEAREA ; (* ADJUST LOC. CNTR *)
END ;
END (* WITH LSP↑ DO *) ;
INSYMBOL
END
ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END
END
ELSE
IF NOT FORW THEN ERROR(123)
END;
%S1\
%S1\ IF NOT FORW THEN
%S1\ WITH LCP↑ DO
%S1\ BEGIN FPRMSZE := FPRM1 ; RPRMSZE := RPRM1 ; SPRMSZE := SPRM1 END;
%S1\
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
IF SY = FORWARDSY THEN
BEGIN
IF FORW THEN ERROR(161)
ELSE LCP↑.FORWDECL := TRUE;
INSYMBOL;
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE
BEGIN LCP↑.FORWDECL := FALSE; NEW(MARKP); (* MARK HEAP *)
REPEAT BLOCK(FSYS,SEMICOLON,LCP);
IF SY = SEMICOLON THEN
BEGIN %IF PRTABLES THEN PRINTTABLES(FALSE);\ INSYMBOL;
IF NOT (SY IN [BEGINSY,PROCSY,FUNCSY]) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE ERROR(14)
UNTIL SY IN [BEGINSY,PROCSY,FUNCSY];
DISPOSE(MARKP); (* RETURN LOCAL ENTRIES ON RUNTIME HEAP *)
END;
LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; INTLABEL := OLDLABEL ;
END (*PROCDECLARATION*) ;
FUNCTION PROCTYPE(FPROCP: CTP): INTEGER ;
BEGIN PROCTYPE := ORD('P') ;
IF FPROCP <> NIL THEN
IF FPROCP↑.IDTYPE <> NIL THEN
WITH FPROCP↑ DO
BEGIN
IF IDTYPE↑.FORM = POWER THEN PROCTYPE := ORD('S')
ELSE IF IDTYPE = REALPTR THEN PROCTYPE := ORD('R')
ELSE IF IDTYPE = BOOLPTR THEN PROCTYPE := ORD('B')
ELSE IF IDTYPE↑.FORM = POINTER THEN
PROCTYPE := ORD('A')
ELSE IF %(IDTYPE = CHARPTR) OR ((IDTYPE↑.FORM = SUBRANGE)
AND (IDTYPE↑.RANGETYPE = CHARPTR)) \
IDTYPE↑.SIZE = 1 THEN PROCTYPE := ORD('C')
ELSE PROCTYPE := ORD('I') ;
END
END (*PROCTYPE*) ;
PROCEDURE BODY(FSYS: SETOFSYS);
CONST CIXMAX = 1000;
TYPE OPRANGE = 0..OPMAX;
CALLED←PROC = RECORD
NAME : ALPHA ;
LVL : LEVRANGE ;
CNT : 1..100 ;
NXT : ↑ CALLED←PROC
END ;
VAR
CALL←HEAD, T2←CLIST, T←CLIST : ↑ CALLED←PROC ;
LOCAL←CALL, (* THIS PROC CALLS A LOCAL PROC *)
% MOD←TRACE, \ (* TRACE VARS BEING MODIFIED *)
MODIFYING : BOOLEAN ; (*A PROGRAM VAR BEING MODIFIED*)
VAR←REF, VAR←MOD : INTEGER ; (* OF VARIABLES ACCESSED/REFERENCED*)
LLCP:CTP; SAVEID:ALPHA;
CSTPTR: CSP;
(*ALLOWS REFERENCING OF NONINTEGER CONSTANTS BY AN INDEX
(INSTEAD OF A POINTER), WHICH CAN BE STORED IN THE P2-FIELD
OF THE INSTRUCTION RECORD UNTIL WRITEOUT.
--> PROCEDURE LOAD, PROCEDURE WRITEOUT*) (*NOT NEEDED IN P←COMP.*)
I, ENTNAME : INTEGER;
LCMAX,LLC1: ADDRRANGE; LCP: CTP;
LLP: LBP; PROCNAME : ALPHA ;
%CTR\ FIRSTLN : INTEGER; CTRNO : CTRRANGE;
PROCEDURE PUTIC;
BEGIN
IF (IC MOD 10 = 0) THEN
%IF ASSEMBLE AND PRTIC THEN \ WRITELN(PRR,' LOC',IC:6) ;
END;
FUNCTION FLDW(NUM : INTEGER) : INTEGER ;
VAR FW: 0..20 ;
BEGIN
FW := 0 ; IF NUM < 0 THEN FW := 1 ;
NUM := ABS(NUM) ;
REPEAT
NUM := NUM DIV 10 ; FW := FW+1 ;
UNTIL NUM = 0 ;
FLDW := FW
END (*FLDW*);
FUNCTION GETTYPE(OPERAND: STP): INTEGER ;
BEGIN GETTYPE := ORD('I') ; (* ASSUME INTEGER TYPE *)
IF OPERAND = NIL THEN BEGIN IF ERRORCOUNT = 0 THEN ERROR(500) END
ELSE
IF OPERAND↑.FORM > POWER THEN GETTYPE := ORD('A')
ELSE
IF OPERAND↑.FORM = POWER THEN GETTYPE := ORD('S')
ELSE
IF OPERAND↑.FORM = POINTER THEN GETTYPE := ORD('A')
ELSE
IF OPERAND = REALPTR THEN GETTYPE := ORD('R')
ELSE
IF OPERAND = BOOLPTR THEN GETTYPE := ORD('B')
ELSE
BEGIN
IF OPERAND↑.SIZE = CHARSIZE THEN GETTYPE := ORD('C')
END
END (*GETTYPE*) ;
PROCEDURE GEN0(FOP: OPRANGE);
BEGIN
IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR,MN[FOP]:4) END;
IC := IC + 1
END (*GEN0*) ;
PROCEDURE GEN1(FOP: OPRANGE; FP2: INTEGER);
VAR K: INTEGER;
BEGIN
IF PRCODE THEN
BEGIN PUTIC; WRITE(PRR,MN[FOP]:4);
IF FOP = 30 THEN (*CSP*) WRITELN(PRR,SNA[FP2]:4)
ELSE IF FOP = 37 THEN (*LCA*)
BEGIN WRITE(PRR,' ''');
WITH CSTPTR↑ DO
FOR K := 1 TO SLNGTH DO
BEGIN WRITE(PRR,SVAL[K]:1);
IF SVAL[K] = '''' THEN WRITE(PRR,'''')
END ;
WRITELN(PRR,'''')
END
ELSE IF (FOP = 26) OR (FOP = 42)
%S1\ OR (FOP = 64) (*PRM*)
THEN (*STO,RET*)
WRITELN(PRR,CHR(FP2):2)
ELSE WRITELN(PRR,FP2:12)
END;
IC := IC + 1
END (*GEN1*) ;
PROCEDURE GEN2(FOP: OPRANGE; FP1,FP2: INTEGER);
VAR I, J, K : INTEGER; %FIRSTMEM : BOOLEAN ;\
BEGIN
IF PRCODE THEN
BEGIN PUTIC; WRITE(PRR,MN[FOP]:4,' ');
CASE FOP OF
%LCW 5JUN78\ 40: (*MOV*)
%LCW 5JUN78\ WRITELN(PRR,FP1:FLDW(FP1),',',FP2:FLDW(FP2));
31,34,35,39,43: (*DEC,INC,IND,LDO,SRO*)
WRITELN(PRR,CHR(FP1),',',FP2:FLDW(FP2)) ;
45,50: (*CHK,LDA*)
WRITELN(PRR,FP1:FLDW(FP1),',',FP2:FLDW(FP2));
47,48,49,52,53,55: (*EQU..NEQ*)
BEGIN WRITE(PRR,CHR(FP1));
IF FP1 = ORD('M') THEN WRITE(PRR,',',FP2:FLDW(FP2));
WRITELN(PRR)
END;
51: (*LDC*)
CASE FP1 OF
0: WRITELN(PRR,'C,''',CHR(FP2):1,'''') ;
1: WRITELN(PRR,'I,',FP2:FLDW(FP2));
2: BEGIN WRITE(PRR,'R,');
WITH CSTPTR↑ DO
FOR K := 1 TO REALLNGTH DO
IF RVAL[K] <> ' ' THEN WRITE(PRR,RVAL[K]);
WRITELN(PRR)
END;
3: WRITELN(PRR,'B,',FP2:1);
4: WRITELN(PRR,'N');
5: BEGIN WRITE(PRR,'S,(');
% FIRSTMEM := TRUE ;
WITH CSTPTR↑ DO
FOR K := 0 TO SETRANGE DO
IF K IN PVAL THEN
BEGIN
IF FIRSTMEM THEN
BEGIN WRITE(PRR,K:FLDW(K)) ;
FIRSTMEM := FALSE
END
ELSE WRITE(PRR,',',K:FLDW(K)) ;
END ;
WRITELN(PRR,')') \
WITH CSTPTR↑ DO
FOR I := 0 TO 3 DO
BEGIN J := 0 ; K := SETRANGE-I*16 ;
FOR K := K DOWNTO K-15 DO
BEGIN J := J*2 ;
IF K IN PVAL THEN J := J+1 ;
END ;
IF I > 0 THEN WRITE(PRR,',') ;
WRITE(PRR, J: FLDW(J) ) ;
END (* FOR I := 0 TO 3 *) ;
WRITELN(PRR,')') ;
END
END
END;
END;
IC := IC + 1
END (*GEN2*) ;
PROCEDURE GEN3(FOP: OPRANGE; FP0,FP1,FP2: INTEGER);
BEGIN
IF PRCODE THEN
BEGIN PUTIC; WRITE(PRR,MN[FOP]:4);
%S1\ IF FOP = 41 THEN (*MST*)
%S1\ WRITE(PRR, FP0:2)
%S1\ ELSE
WRITE(PRR, CHR(FP0):2) ;
WRITELN(PRR, ',', FP1:FLDW(FP1), ',', FP2:FLDW(FP2)) ;
END;
IC := IC + 1
END (*GEN3*) ;
PROCEDURE LOAD;
BEGIN
WITH GATTR DO
IF TYPTR <> NIL THEN
BEGIN
CASE KIND OF
CST: IF (TYPTR↑.FORM = SCALAR) AND (TYPTR <> REALPTR) THEN
IF TYPTR = BOOLPTR THEN GEN2(51(*LDC*),3,CVAL.IVAL)
ELSE
IF TYPTR = CHARPTR THEN GEN2(51(*LDC*),0,CVAL.IVAL)
ELSE GEN2(51(*LDC*),1,CVAL.IVAL) (*INTEGER*)
ELSE
IF TYPTR = NILPTR THEN GEN2(51(*LDC*),4,0)
ELSE
BEGIN
CSTPTR := CVAL.VALP;
IF TYPTR = REALPTR THEN
GEN2(51(*LDC*),2,0)
ELSE
GEN2(51(*LDC*),5,0)
END;
VARBL: CASE ACCESS OF
DRCT: % IF VLEVEL <= 1 THEN
GEN2(39"*LDO*",GETTYPE(BTYPE),DPLMT)
ELSE \ GEN3(54(*LOD*),GETTYPE(BTYPE),
% LEVEL-\ VLEVEL,DPLMT);
INDRCT: GEN2(35(*IND*),GETTYPE(BTYPE),IDPLMT);
INXD: ERROR(400)
END;
EXPR:
END;
IF KIND = VARBL THEN VAR←REF := VAR←REF+1 ;
KIND := EXPR
END
END (*LOAD*) ;
PROCEDURE STORE(VAR FATTR: ATTR);
BEGIN
WITH FATTR DO
IF TYPTR <> NIL THEN
CASE ACCESS OF
DRCT: GEN3(56(*STR*),GETTYPE(BTYPE),VLEVEL,DPLMT);
INDRCT: IF IDPLMT <> 0 THEN ERROR(400)
ELSE GEN1(26(*STO*),GETTYPE(BTYPE));
INXD: ERROR(400)
END
END (*STORE*) ;
PROCEDURE LOADADDRESS;
BEGIN
WITH GATTR DO
IF TYPTR <> NIL THEN
BEGIN
CASE KIND OF
CST: IF STRING(TYPTR) THEN
BEGIN
CSTPTR := CVAL.VALP ; GEN1(37(*LCA*),0) ;
END
ELSE ERROR(400);
VARBL: CASE ACCESS OF
DRCT: GEN2(50(*LDA*),VLEVEL,DPLMT);
INDRCT: IF IDPLMT <> 0 THEN
GEN2(34(*INC*),ORD('A'),IDPLMT);
INXD: ERROR(400)
END;
EXPR: ERROR(400)
END;
KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0
END
END (*LOADADDRESS*) ;
PROCEDURE GENFJP(FADDR: INTEGER);
BEGIN LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN ERROR(144);
IF PRCODE THEN BEGIN PUTIC;
WRITELN(PRR,MN[33]:4,' L',FADDR:FLDW(FADDR)) END;
IC := IC + 1
END (*GENFJP*) ;
PROCEDURE GENUJPFJP(FOP: OPRANGE; FP2: INTEGER);
BEGIN
IF PRCODE THEN
BEGIN PUTIC; WRITELN(PRR, MN[FOP]:4, ' L',FP2:FLDW(FP2)) END;
IC := IC + 1
END (*GENUJPFJP*);
PROCEDURE GENCUPENT(FOP: OPRANGE;FP0,FP1,FP2: INTEGER;PROCNAME: ALPHA);
VAR TEMPNAME : ALPHA ;
PROCEDURE MKNAME(VAR ALB: ALPHA; NLB: INTEGER ) ;
VAR I, J: INTEGER ;
BEGIN
I := 1 ;
WHILE (I < 6) AND (ALB[I] <> ' ') DO
BEGIN IF ALB[I] = '←' THEN ALB[I] := '$' ; I := I+1 END ;
FOR J := 8 DOWNTO I DO
BEGIN
ALB[J] := CHR( ORD('0')+ NLB MOD 10 ) ;
NLB := NLB DIV 10 ;
END ;
END (*MKNAME*) ;
BEGIN (*GENCUPENT*)
IF PRCODE THEN
BEGIN PUTIC ; TEMPNAME := PROCNAME ; (*TO PRESERVE FULL NAME*)
IF FOP = 46 THEN (*CUP*)
BEGIN MKNAME(TEMPNAME,FP2) ;
WRITELN(PRR,MN[46],CHR(FP0):2,',',FP1:FLDW(FP1),',',TEMPNAME:8);
END
ELSE (* ENT *)
BEGIN
(*EJG 12FEB78 : *)
(**) IF OLDIC = 0 THEN WRITELN(PRR,' BGN ', ord(ASSEMBLE):1, ',',
(**) ord(GET←STAT):1, ',', ord(ASMVERB):1) ;
IF FPROCP <> NIL THEN MKNAME(TEMPNAME,FP2) ;
WRITELN(PRR, TEMPNAME:8, MN[32], CHR(FP0):2, ',',
LEVEL:FLDW(LEVEL), ',L', FP1:FLDW(FP1), ' ',
(*EJG 12FEB78 : *)
(**) PROCNAME:8, ord(SAVEREGS):4, ord(SAVEFPRS):2, ord(DEBUG):2) ;
END ;
END ;
IC := IC + 1
END (*GENCUPENT*);
PROCEDURE GENDEF(L1, L2: ADDRRANGE ) ;
BEGIN
IF PRCODE THEN WRITELN(PRR,'L', L1:FLDW(L1), MN[63(*DEF*)], L2:10);
END (*GENDEF*) ;
PROCEDURE CHKBNDS(FSP: STP);
VAR LMIN,LMAX: INTEGER;
BEGIN
IF FSP <> NIL THEN
IF FSP <> BOOLPTR THEN
IF FSP <> INTPTR THEN
IF FSP <> REALPTR THEN
IF FSP↑.FORM <= POINTER THEN
BEGIN
GETBOUNDS(FSP,LMIN,LMAX);
IF LMAX-LMIN <= 0 THEN
IF ASSIGN THEN GEN3(45(*CHK*),ORD('A'),-1,0)
ELSE (* ACCESS *) GEN3(45(*CHK*),ORD('A'),0,0)
ELSE GEN3(45(*CHK*),ORD('I'),LMIN,LMAX) ;
END
END (*CHKBNDS*);
PROCEDURE PUTLABEL(LABNAME: INTEGER);
BEGIN IF PRCODE THEN WRITELN(PRR, 'L', LABNAME:FLDW(LABNAME),' LAB')
END (*PUTLABEL*);
%CTR\
%CTR\
%CTR\ FUNCTION CTRGEN : CTRRANGE;
%CTR\
%CTR\ BEGIN (* CREATE A UNIQUE STATEMENT COUNTER AND EMIT P-CODE TO INCREME*)
%CTR\ (* IT *)
%CTR\ (* R. L. SITES 3 AUG 77 *)
%CTR\ CTRGEN := CTRCNT;
%CTR\ IF CTROPTION THEN
%CTR\ BEGIN
%CTR\ GEN1(39(*CTI*), CTRCNT);
%CTR\ CTRCNT := CTRCNT+1;
%CTR\ END;
%CTR\ END; (* CTRGEN *)
%CTR\
%CTR\ PROCEDURE CTREMIT(CTRT:CTRTYPE; CTRNO:CTRRANGE; FLN, MLN, LLN:INTEGER) ;
%CTR\
%CTR\
%CTR\ BEGIN (* WRITE AN ENTRY DESCRIBING A STATEMENT COUNTER. *)
%CTR\ (* R. L. SITES 3 AUG 77 *)
%CTR\ IF CTROPTION THEN
%CTR\ BEGIN %\ (* IF FIRSTCTR THEN
%CTR\ % BEGIN WRITELN(CTRTBL , COMPDATE); WRITELN(
%CTR\ % COMPTIME);
%CTR\ % FIRSTCTR := FALSE END;
%CTR\ % WRITELN(%CTR\%QRR,(((ORD(CTRT)*MAXCTR+CTRNO)*MAXLN+FLN)
%CTR\ % *MAXLN+MLN)*MAXLN+LLN:20); *) %\
%CTR\ WRITELN(QRD, ORD(CTRT):4, CTRNO:6, FLN:7, MLN:7, LLN:7 );
%CTR\ END
%CTR\ (* PACKING MUST EITHER FIT IN 46 BITS OR MAXCTR,MAXLN MUST BE *)
%CTR\ (* POWERS OF TWO. *)
%CTR\ END; (* CTREMIT *)
%CTR\
PROCEDURE STATEMENT(FSYS: SETOFSYS);
LABEL 1;
VAR LCP: CTP; LLP: LBP; TTOP : DISPRANGE ;
%CTR\ CTRNO : CTRRANGE;
PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD;
PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
VAR LATTR: ATTR; LCP: CTP; LMIN,LMAX: INTEGER;
INDEXING : BOOLEAN ;
BEGIN
INDEXING := FALSE ;
WITH FCP↑, GATTR DO
BEGIN TYPTR := IDTYPE; KIND := VARBL;
IF GET←STAT THEN
BEGIN
IF MODIFYING THEN WRITE(QRR,' MOD')
ELSE WRITE(QRR,' REF') ;
WRITE(QRR, CHR(GETTYPE(%BTYPE\ TYPTR)), ' ':2 );
END (*GET←STAT*) ;
CASE KLASS OF
VARS:
IF VKIND = ACTUAL THEN
BEGIN ACCESS := DRCT; VLEVEL := VLEV;
DPLMT := VADDR
END
ELSE
BEGIN
IF GET←STAT THEN WRITE(QRR,' IND',VLEV:3,VADDR:8);
GEN3(54(*LOD*),ORD('A'),VLEV,VADDR);
ACCESS := INDRCT; IDPLMT := 0
END;
FIELD:
WITH DISPLAY[DISX] DO
IF OCCUR = CREC THEN
BEGIN ACCESS := DRCT; VLEVEL := CLEV;
DPLMT := CDSPL + FLDADDR
END
ELSE
BEGIN
GEN3(54(*LOD*),ORD('A'), LEVEL,VDSPL) ;
IF GET←STAT THEN WRITE(QRR,' IND',LEVEL:3,VDSPL:8);
ACCESS := INDRCT; IDPLMT := FLDADDR
END;
FUNC:
IF PFDECKIND = STANDARD THEN ERROR(150)
ELSE
IF PFLEV = 0 THEN ERROR(150) (*EXTERNAL FCT*)
ELSE
IF PFKIND = FORMAL THEN ERROR(151)
ELSE
IF (FPROCP <> FCP) THEN ERROR(177)
ELSE
BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1;
DPLMT := FNCRSLT ; (*RELAT. ADDR. OF FCT. RESULT*)
(* IF MODIFYING THEN
WRITE(QRR,' DIR',VLEVEL:3, DPLMT:7) ; *)
END
END (*CASE*) ;
GATTR.BTYPE := GATTR.TYPTR ;
END (*WITH*);
IF NOT (SY IN SELECTSYS + FSYS) THEN
BEGIN ERROR(59); SKIP(SELECTSYS + FSYS) END;
WHILE SY IN SELECTSYS DO
BEGIN
(*[*) IF SY = LBRACK THEN
BEGIN
IF GET←STAT THEN
WITH GATTR DO
BEGIN
IF ACCESS = DRCT THEN
WRITE(QRR, ' DIR',VLEVEL:3,DPLMT:8)
ELSE IF (ACCESS = INDRCT) AND (IDPLMT <> 0) THEN
WRITE(QRR,' DPM ', IDPLMT:8) ;
WRITE(QRR,' INX ') ;
IF MODIFYING THEN
BEGIN INDEXING := TRUE ; MODIFYING := FALSE END ;
END ;
REPEAT LATTR := GATTR;
WITH LATTR DO
IF TYPTR <> NIL THEN
IF TYPTR↑.FORM <> ARRAYS THEN
BEGIN ERROR(138); TYPTR := NIL END;
LOADADDRESS;
INSYMBOL; EXPRESSION(FSYS + [COMMA,RBRACK]);
LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(113);
IF LATTR.TYPTR <> NIL THEN
WITH LATTR.TYPTR↑ DO
BEGIN
IF COMPTYPES(INXTYPE,GATTR.TYPTR) THEN
BEGIN
IF INXTYPE <> NIL THEN
BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
IF DEBUG THEN
GEN3(45(*CHK*),ORD('J'),LMIN,LMAX) ;
IF LMIN > 0 THEN
GEN2(31(*DEC*),GETTYPE(GATTR.BTYPE),LMIN)
ELSE IF LMIN < 0 THEN
GEN2(34(*INC*),GETTYPE(GATTR.BTYPE),-LMIN)
(*OR SIMPLY GEN1(31,LMIN)*)
END
END
ELSE ERROR(139);
WITH GATTR DO
BEGIN TYPTR := AELTYPE; KIND := VARBL;
ACCESS := INDRCT; IDPLMT := 0 ;
IF GATTR.TYPTR <> NIL THEN
BEGIN LMIN := TYPTR↑.SIZE ;
ALIGN(LMIN,TYPTR↑.ALN) ;
GEN1(36(*IXA*),LMIN)
END (*TYPTR <> NIL*) ;
END (*WITH GATTR DO*) ;
END
UNTIL SY <> COMMA;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) ;
IF INDEXING THEN
BEGIN MODIFYING := TRUE ; INDEXING := FALSE END ;
END (*IF SY = LBRACK*)
ELSE
(*.*) IF SY = PERIOD THEN
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR <> NIL THEN
IF TYPTR↑.FORM <> RECORDS THEN
BEGIN ERROR(140); TYPTR := NIL END;
INSYMBOL;
IF SY = IDENT THEN
BEGIN
IF TYPTR <> NIL THEN
BEGIN SEARCHSECTION(TYPTR↑.FSTFLD,LCP);
IF LCP = NIL THEN
BEGIN ERROR(152); TYPTR := NIL END
ELSE
WITH LCP↑ DO
BEGIN TYPTR := IDTYPE;
CASE ACCESS OF
DRCT: DPLMT := DPLMT + FLDADDR;
INDRCT: IDPLMT := IDPLMT + FLDADDR;
INXD: ERROR(400)
END
END
END;
INSYMBOL
END (*SY = IDENT*)
ELSE ERROR(2)
END (*WITH GATTR*)
END (*IF SY = PERIOD*)
ELSE
(*↑*) BEGIN
IF GATTR.TYPTR <> NIL THEN
WITH GATTR,TYPTR↑ DO
IF FORM = POINTER THEN
BEGIN
IF GET←STAT THEN
IF ACCESS = DRCT THEN
WRITE(QRR,' PTR',VLEVEL:3,DPLMT:8)
ELSE (*ACCESS = INDRCT *)
WRITE(QRR,' DPM ',%LEVEL:3,\IDPLMT:8) ;
LOAD ;
IF DEBUG THEN CHKBNDS(GATTR.TYPTR) ;
TYPTR := ELTYPE ;
WITH GATTR DO
BEGIN KIND := VARBL; ACCESS := INDRCT;
IDPLMT := 0
END
END
ELSE
IF FORM = FILES THEN TYPTR := FILTYPE
ELSE ERROR(141);
INSYMBOL
END;
IF NOT (SY IN FSYS + SELECTSYS) THEN
BEGIN ERROR(6); SKIP(FSYS + SELECTSYS) END ;
GATTR.BTYPE := GATTR.TYPTR ;
END (*WHILE*) ;
IF GET←STAT THEN
WITH GATTR DO
BEGIN
IF ACCESS = DRCT THEN
WRITE(QRR,' DIR', VLEVEL:3,DPLMT:8)
ELSE IF (ACCESS = INDRCT) AND (IDPLMT <> 0) THEN
WRITE(QRR, ' DPM ',IDPLMT:8) ;
IF MODIFYING THEN WRITE(QRR, ' MND ')
ELSE WRITE(QRR,' RND ') ;
END ;
END (*SELECTOR*) ;
PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
VAR LKEY: 1..15;
PROCEDURE VARIABLE(FSYS: SETOFSYS);
VAR LCP: CTP;
BEGIN
IF SY = IDENT THEN
BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END
ELSE BEGIN ERROR(2); LCP := UVARPTR END;
SELECTOR(FSYS,LCP)
END (*VARIABLE*) ;
PROCEDURE RWSETUP(DFILE: ALPHA) ;
(* TO SET UP FILE ADDRESS PARAMETER FOR READ/WRITE *)
VAR LCP : CTP ; SAVED : BOOLEAN ; TEMPID : ALPHA ; TEMPSY : SYMBOL ;
BEGIN SAVED := TRUE ;
IF SY = IDENT THEN
BEGIN SEARCHID([VARS,FIELD,FUNC],LCP) ;
IF LCP↑.IDTYPE <> NIL THEN
WITH LCP↑.IDTYPE↑ DO
IF FORM = FILES THEN
IF FILTYPE = CHARPTR THEN SAVED := FALSE
ELSE ERROR(398) ;
END (* SY = IDENT *) ;
IF SAVED THEN (* USE IMPLIED FILE NAME *)
BEGIN TEMPSY := SY ; TEMPID := ID ; SY := COMMA ; ID := DFILE ;
SEARCHID([VARS],LCP) ;
END (* IF SAVED *)
ELSE INSYMBOL ;
SELECTOR(FSYS+[COMMA,RPARENT],LCP) ; LOADADDRESS ; (* GET FILE ADR *)
GEN1(30(*CSP*),29(*SIO*)) ;
IF SAVED THEN BEGIN ID := TEMPID ; SY := TEMPSY END ;
END (*RWSETUP*) ;
PROCEDURE GETPUTRESETREWRITE;
BEGIN VARIABLE(FSYS + [RPARENT]); LOADADDRESS;
IF EBCDFLG THEN
BEGIN GEN2(34(*INC*),ORD('A'),1000) ; EBCDFLG := FALSE END ;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> FILES THEN ERROR(116);
GEN1(30(*CSP*),29(*SIO*)) ;
GEN1(30(*CSP*),LKEY(*GET,PUT,RES,REW*)) ;
GEN1(30(*CSP*),30(*EIO*)) ;
END (*GETPUTRESETREWRITE*) ;
PROCEDURE READ1;
% VAR LCP:CTP; LLEV:LEVRANGE; LADDR:ADDRRANGE; \
BEGIN %LLEV := 1 ; LADDR := FIRSTFILBUF ;\(*ASSUME 'INPUT'*)
IF SY = IDENT THEN RWSETUP('INPUT ')
ELSE BEGIN ERROR(2) ; INSYMBOL END ;
IF SY = COMMA THEN INSYMBOL ;
IF SY = IDENT THEN
REPEAT MODIFYING := TRUE ;
VARIABLE(FSYS + [COMMA,RPARENT]) ; MODIFYING := FALSE ;
LOADADDRESS ;
IF GATTR.TYPTR <> NIL THEN
IF STRING(GATTR.TYPTR) THEN
BEGIN
GEN2(51(*LDC*),1,GATTR.TYPTR↑.SIZE DIV CHARSIZE) ;
GEN1(30(*CSP*),27(*RDS*))
END
ELSE
BEGIN
IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN
GEN1(30(*CSP*),24(*RDI*))
ELSE
IF COMPTYPES(REALPTR,GATTR.TYPTR) THEN
GEN1(30(*CSP*),25(*RDR*))
ELSE
IF COMPTYPES(CHARPTR,GATTR.TYPTR) THEN
GEN1(30(*CSP*),5(*RDC*))
ELSE
IF COMPTYPES(BOOLPTR,GATTR.TYPTR) THEN
GEN1(30(*CSP*),12(*RDB*))
ELSE ERROR(116) ;
END ;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST ;
IF LKEY = 11 THEN
BEGIN
GEN1(30(*CSP*),26(*RLN*))
END ;
GEN1(30(*CSP*),30(*EIO*)) ;
END (*READ*) ;
PROCEDURE WRITE1;
VAR LSP: STP; DEFAULT : BOOLEAN; LLKEY: 1..15;
LEN:ADDRRANGE;
BEGIN LLKEY := LKEY; TEST := FALSE ;
RWSETUP('OUTPUT ') ;
IF SY = RPARENT THEN
BEGIN TEST := TRUE ; IF LLKEY = 6 THEN ERROR(116) ; END ;
IF SY = COMMA THEN INSYMBOL ;
IF NOT TEST THEN
REPEAT EXPRESSION(FSYS+[COMMA,COLON,RPARENT]) ;
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN
IF LSP↑.FORM <= SUBRANGE THEN LOAD ELSE LOADADDRESS;
IF SY = COLON THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,COLON,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(116);
LOAD; DEFAULT := FALSE
END
ELSE DEFAULT := TRUE;
IF SY = COLON THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(116);
IF LSP <> REALPTR THEN ERROR(124);
LOAD; ERROR(398);
END
ELSE
IF LSP = INTPTR THEN
BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,12);
GEN1(30(*CSP*),6(*WRI*))
END
ELSE
IF LSP = REALPTR THEN
BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,14);
GEN1(30(*CSP*),8(*WRR*))
END
ELSE
IF LSP = CHARPTR THEN
BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,1);
GEN1(30(*CSP*),9(*WRC*))
END
ELSE
IF LSP = BOOLPTR THEN
BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,5);
GEN1(30(*CSP*),13(*WRB*))
END
ELSE
IF LSP <> NIL THEN
BEGIN
IF LSP↑.FORM = SCALAR THEN ERROR(398)
ELSE
IF STRING(LSP) THEN
BEGIN LEN := LSP↑.SIZE DIV CHARSIZE;
IF DEFAULT THEN
GEN2(51(*LDC*),1,LEN);
GEN2(51(*LDC*),1,LEN);
GEN1(30(*CSP*),10(*WRS*))
END
ELSE ERROR(116)
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL ;
UNTIL TEST;
IF LLKEY = 12 THEN (*WRITELN*)
BEGIN
GEN1(30(*CSP*),22(*WLN*))
END ;
GEN1(30(*CSP*),30(*EIO*)) ;
END (*WRITE*) ;
PROCEDURE PACK1;
VAR LSP,LSP1: STP;
BEGIN ERROR(398); VARIABLE(FSYS + [COMMA,RPARENT]);
LSP := NIL; LSP1 := NIL;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN LSP := INXTYPE; LSP1 := AELTYPE END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
EXPRESSION(FSYS + [COMMA,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(116)
ELSE
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
VARIABLE(FSYS + [RPARENT]);
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN
IF NOT COMPTYPES(AELTYPE,LSP1)
OR NOT COMPTYPES(INXTYPE,LSP) THEN
ERROR(116)
END
ELSE ERROR(116)
END (*PACK*) ;
PROCEDURE UNPACK1;
VAR LSP,LSP1: STP;
BEGIN ERROR(398); VARIABLE(FSYS + [COMMA,RPARENT]);
LSP := NIL; LSP1 := NIL;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN LSP := INXTYPE; LSP1 := AELTYPE END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
VARIABLE(FSYS + [COMMA,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN
IF NOT COMPTYPES(AELTYPE,LSP1)
OR NOT COMPTYPES(INXTYPE,LSP) THEN
ERROR(116)
END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
EXPRESSION(FSYS + [RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(116)
ELSE
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116);
END (*UNPACK*) ;
PROCEDURE NEW1;
LABEL 1;
VAR LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
BEGIN VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS;
LSP := NIL; VARTS := 0; LSIZE := 0;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = POINTER THEN
BEGIN
IF ELTYPE <> NIL THEN
BEGIN LSIZE := ELTYPE↑.SIZE;
IF ELTYPE↑.FORM = RECORDS THEN LSP := ELTYPE↑.RECVAR
END
END
ELSE ERROR(116);
WHILE SY = COMMA DO
BEGIN INSYMBOL;CONSTANT(FSYS + [COMMA,RPARENT],LSP1,LVAL);
VARTS := VARTS + 1;
(*CHECK TO INSERT HERE: IS CONSTANT IN TAGFIELDTYPE RANGE*)
IF LSP = NIL THEN ERROR(158)
ELSE
IF LSP↑.FORM <> TAGFLD THEN ERROR(162)
ELSE
IF LSP↑.TAGFIELDP <> NIL THEN
IF STRING(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159)
ELSE
IF COMPTYPES(LSP↑.TAGFIELDP↑.IDTYPE,LSP1) THEN
BEGIN
LSP1 := LSP↑.FSTVAR;
WHILE LSP1 <> NIL DO
WITH LSP1↑ DO
IF VARVAL.IVAL = LVAL.IVAL THEN
BEGIN LSIZE := SIZE; LSP := SUBVAR;
GOTO 1
END
ELSE LSP1 := NXTVAR;
LSIZE := LSP↑.SIZE; LSP := NIL;
END
ELSE ERROR(116);
1: END (*WHILE*) ;
ALIGN(LSIZE,MXDATASZE) ;
GEN1(58(*NEW*),LSIZE);
END (*NEW*) ;
PROCEDURE MARK1;
BEGIN VARIABLE(FSYS+[RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM = POINTER THEN
BEGIN LOADADDRESS; GEN0(59(*SAV*)) END
ELSE ERROR(125)
END(*MARK*);
PROCEDURE RELEASE1;
BEGIN VARIABLE(FSYS+[RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM = POINTER THEN
BEGIN LOAD; GEN0(60(*RST*)) END
ELSE ERROR(125)
END (*RELEASE*);
PROCEDURE TRAP1 ;
(*THIS PROCEDURE IS TO FACILITATE COMMUNICATION WITH THE OUTSIDE WORLD
(* AND PROVIDE BREAK POINTS IN THE PASCAL PROGRAM.
(* 'TRAP(I, R)' RETURNS THE INTEGER CONSTANT I AS WELL AS A POINTER
(* TO THE SECOND PARAMETER 'R' (I.E. ADDRESS OF R) TO THE OPERATING
(* SYSTEM. THE FIRST PARAMETER IS INTENDED TO BE USED AS A
(* 'FUNCTION NUMBER' AND THE SECOND ONE AS THE 'VAR' TYPE ARGUMENT
(* WHICH MAY BE INSPECTED AND MODIFIED, TO THAT FUNCTION *)
BEGIN EXPRESSION(FSYS+[RPARENT,COMMA]) ;
IF GATTR.TYPTR <> INTPTR THEN ERROR(116)
ELSE
BEGIN LOAD ;
IF SY <> COMMA THEN ERROR(6)
ELSE
BEGIN INSYMBOL ;
EXPRESSION(FSYS+[RPARENT]) ;
WITH GATTR DO
IF TYPTR <> NIL THEN
BEGIN
IF KIND <> VARBL THEN
IF TYPTR↑.FORM <= POWER THEN
BEGIN LOAD ;
KIND := VARBL ; ACCESS := DRCT ; VLEVEL := LEVEL ;
ALIGN(LC,MXDATASZE) ; DPLMT := LC ; BTYPE := TYPTR ;
STORE(GATTR) ;
END ;
LOADADDRESS ;
END ;
END (*WITH*) ;
END ;
GEN1(30(*CSP*),28(*TRP*)) ;
END (* TRAP1 *) ;
PROCEDURE ABS1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR = INTPTR THEN GEN0(0(*ABI*))
ELSE
IF GATTR.TYPTR = REALPTR THEN GEN0(1(*ABR*))
ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END
END (*ABS*) ;
PROCEDURE SQR1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR = INTPTR THEN GEN0(24(*SQI*))
ELSE
IF GATTR.TYPTR = REALPTR THEN GEN0(25(*SQR*))
ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END
END (*SQR*) ;
PROCEDURE TRUNC1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> REALPTR THEN ERROR(125);
GEN0(27(*TRC*));
GATTR.TYPTR := INTPTR
END (*TRUNC*) ;
PROCEDURE ODD1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
GEN0(20(*ODD*));
GATTR.TYPTR := BOOLPTR
END (*ODD*) ;
PROCEDURE ORD1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM >= POWER THEN ERROR(125);
GEN0(61(*ORD*)) ;
GATTR.TYPTR := INTPTR
END (*ORD1*) ;
PROCEDURE CHR1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
GEN0(62(*CHR*)) ;
GATTR.TYPTR := CHARPTR
END (*CHR*) ;
PROCEDURE PREDSUCC;
BEGIN (*ERROR(398);*) (*TRANSLATES INTO 'DEC' AND 'INC'*)
IF GATTR.TYPTR <> NIL THEN
IF (GATTR.TYPTR = REALPTR) OR (GATTR.TYPTR↑.FORM <> SCALAR) THEN
ERROR(125) ;
IF LKEY = 7 THEN GEN2(31(*DEC*),GETTYPE(GATTR.BTYPE),1)
ELSE IF LKEY = 8 THEN GEN2(34(*INC*),GETTYPE(GATTR.BTYPE),1)
ELSE (* IF LKEY = 9 THEN *) GEN1(30(*CSP*),31(*CLK*)) ;
END (*PREDSUCC*) ;
PROCEDURE EOF1;
BEGIN
GEN1(30(*CSP*),29(*SIO*)) ;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> FILES THEN ERROR(125);
IF LKEY = 10 THEN GEN1(30(*CSP*),23(*EOF*))
ELSE GEN1(30(*CSP*),14(*ELN*));
GEN1(30(*CSP*),30(*EIO*)) ;
GATTR.TYPTR := BOOLPTR
END (*EOF*) ;
PROCEDURE CALLNONSTANDARD;
VAR NXT,LCP: CTP; LSP: STP; LKIND: IDKIND; LB: BOOLEAN;
LOCPAR, LLC: ADDRRANGE;
BEGIN LOCPAR := 0;
WITH FCP↑ DO
BEGIN NXT := NEXT; LKIND := PFKIND;
IF NOT XTERN THEN
BEGIN
%S0\ % GEN1(41"*MST*",PFLEV) ; \
%S1\ GEN3(41(*MST*), PFLEV+1, FPRMSZE, RPRMSZE) ;
T←CLIST := CALL←HEAD ;
WHILE NAME > T←CLIST↑.NAME DO T←CLIST := T←CLIST↑.NXT ;
IF T←CLIST↑.NAME <> NAME THEN
BEGIN NEW(T2←CLIST) ; T2←CLIST↑ := T←CLIST↑ ;
T←CLIST↑.NAME := NAME ; T←CLIST↑.NXT := T2←CLIST ;
T←CLIST↑.CNT := 1 ; T←CLIST↑.LVL := PFLEV ;
IF PFLEV = LEVEL THEN LOCAL←CALL := TRUE ;
END
ELSE T←CLIST↑.CNT := T←CLIST↑.CNT+1 ;
END (* IF NOT XTERN *) ;
END;
IF SY = LPARENT THEN
BEGIN LLC := LC;
REPEAT LB := FALSE; (*DECIDE WHETHER PROC/FUNC MUST BE PASSED*)
IF LKIND = ACTUAL THEN
BEGIN
IF NXT = NIL THEN ERROR(126)
ELSE LB := NXT↑.KLASS IN [PROC,FUNC]
END ELSE ERROR(398);
(*FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS
ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION
PARAMETERS*)
INSYMBOL;
IF LB THEN (*PASS FUNCTION OR PROCEDURE*)
BEGIN ERROR(398);
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + [COMMA,RPARENT]) END
ELSE
BEGIN
IF NXT↑.KLASS = PROC THEN SEARCHID([PROC],LCP)
ELSE
BEGIN SEARCHID([FUNC],LCP);
IF NOT COMPTYPES(LCP↑.IDTYPE,NXT↑.IDTYPE) THEN
ERROR(128)
END;
INSYMBOL;
IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END
END
END (*IF LB*)
ELSE
BEGIN
IF NXT <> NIL THEN
IF NXT↑.VKIND = FORMAL THEN MODIFYING := TRUE ;
EXPRESSION(FSYS + [COMMA,RPARENT]);
MODIFYING := FALSE ;
IF GATTR.TYPTR <> NIL THEN
IF LKIND = ACTUAL THEN
BEGIN
IF NXT <> NIL THEN
BEGIN LSP := NXT↑.IDTYPE;
IF LSP <> NIL THEN
BEGIN
IF (NXT↑.VKIND = ACTUAL) THEN
IF LSP↑.FORM <= POWER THEN
BEGIN LOAD;
IF DEBUG THEN
BEGIN ASSIGN := TRUE ;
CHKBNDS(LSP) ; ASSIGN := FALSE ;
END ;
IF COMPTYPES(REALPTR,LSP)
AND (GATTR.TYPTR = INTPTR) THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END;
LOCPAR := LOCPAR+ 1 (*LSP↑.SIZE*) ;
IF PACKDATA THEN
BEGIN
IF LSP↑.SIZE = 4 THEN GEN0(61(*ORD*));
IF LSP↑.SIZE = 1 THEN GEN0(62(*CHR*));
END (*PACKDATA*) ;
%S1\ IF NOT FCP↑.XTERN THEN
%S1\ GEN1(64(*PRM*), GETTYPE(LSP));
END
ELSE
BEGIN
LOADADDRESS;
LOCPAR := LOCPAR+ 1 (*PTRSIZE*);
%S1\ IF NOT FCP↑.XTERN THEN
%S1\ GEN1(64(*PRM*), ORD('A')) ;
END
ELSE (* VKIND = FORMAL I.E. VAR PARM *)
IF GATTR.KIND = VARBL THEN
BEGIN LOADADDRESS;
LOCPAR := LOCPAR + 1 (*PTRSIZE*);
%S1\ IF NOT FCP↑.XTERN THEN
%S1\ GEN1(64(*PRM*), ORD('A')) ;
IF GATTR.BTYPE↑.SIZE <> LSP↑.SIZE THEN
ERROR(142) ;
END
ELSE ERROR(154);
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN
ERROR(142)
END
END
END
ELSE (*LKIND = FORMAL*)
BEGIN (*PASS FORMAL PROC/FUNC PARAM*)
END
END;
IF (LKIND = ACTUAL) AND (NXT <> NIL) THEN NXT := NXT↑.NEXT
UNTIL SY <> COMMA;
LC := LLC;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (*IF LPARENT*);
LOCPAR := LOCPAR*2 ;
IF LKIND = ACTUAL THEN
BEGIN IF NXT <> NIL THEN ERROR(126);
WITH FCP↑ DO
IF XTERN THEN GEN1(30(*CSP*),PFNAME)
ELSE
BEGIN
IF SAVEFP THEN LOCPAR := LOCPAR+1 ; (*ENCODE SAVE FPR FLG*)
GENCUPENT(46(*CUP*),PROCTYPE(FCP),LOCPAR,PFNAME,NAME);
END ;
END;
GATTR.TYPTR := FCP↑.IDTYPE ; GATTR.BTYPE := GATTR.TYPTR ;
END (*CALLNONSTANDARD*) ;
BEGIN (*CALL*)
IF FCP↑.PFDECKIND = STANDARD THEN
BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
LKEY := FCP↑.KEY;
IF FCP↑.KLASS = PROC THEN
CASE LKEY OF
1,2,
3,4: GETPUTRESETREWRITE;
5,11: READ1;
6,12: WRITE1;
7: PACK1;
8: UNPACK1;
9: NEW1;
10: RELEASE1;
13: MARK1;
14: TRAP1
END
ELSE
BEGIN EXPRESSION(FSYS + [RPARENT]);
IF LKEY <= 9 THEN LOAD ELSE LOADADDRESS;
CASE LKEY OF
1: ABS1;
2: SQR1;
3: TRUNC1;
4: ODD1;
5: ORD1;
6: CHR1;
7,8,9:PREDSUCC;
10,11:EOF1
END (*CASE LKEY OF*) ;
GATTR.BTYPE := GATTR.TYPTR ;
END;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (*STANDARD PROCEDURES AND FUNCTIONS*)
ELSE CALLNONSTANDARD
END (*CALL*) ;
PROCEDURE EXPRESSION;
VAR LATTR: ATTR; LOP: OPERATOR; TYPIND: CHAR; LSIZE: ADDRRANGE;
PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
VAR LATTR: ATTR; LOP: OPERATOR; SIGNED: BOOLEAN;
PROCEDURE TERM(FSYS: SETOFSYS);
VAR LATTR: ATTR; LOP: OPERATOR;
PROCEDURE FACTOR(FSYS: SETOFSYS);
VAR LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
CSTPART: SET OF 0..SETRANGE; LSP: STP; I: 0..64 ;
BEGIN
IF NOT (SY IN FACBEGSYS) THEN
BEGIN ERROR(58); SKIP(FSYS + FACBEGSYS);
GATTR.TYPTR := NIL
END;
WHILE SY IN FACBEGSYS DO
BEGIN
CASE SY OF
(*ID*) IDENT:
BEGIN SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
INSYMBOL;
IF LCP↑.KLASS = FUNC THEN
BEGIN CALL(FSYS,LCP);
WITH GATTR DO
BEGIN KIND := EXPR;
IF TYPTR <> NIL THEN
IF TYPTR↑.FORM=SUBRANGE THEN
TYPTR := TYPTR↑.RANGETYPE
END
END
ELSE
IF LCP↑.KLASS = KONST THEN
WITH GATTR, LCP↑ DO
BEGIN TYPTR := IDTYPE; KIND := CST;
CVAL := VALUES; GATTR.BTYPE := GATTR.TYPTR
END
ELSE
BEGIN SELECTOR(FSYS,LCP);
IF GATTR.TYPTR<>NIL THEN(*ELIM.SUBR.TYPES TO*)
WITH GATTR,TYPTR↑ DO(*SIMPLIFY LATER TESTS*)
IF FORM = SUBRANGE THEN
TYPTR := RANGETYPE
END
END;
(*CST*) INTCONST:
BEGIN
WITH GATTR DO
BEGIN TYPTR := INTPTR; KIND := CST;
CVAL := VAL; BTYPE := TYPTR
END;
INSYMBOL
END;
REALCONST:
BEGIN
WITH GATTR DO
BEGIN TYPTR := REALPTR; KIND := CST;
CVAL := VAL
END;
INSYMBOL
END;
STRINGCONST:
BEGIN
WITH GATTR DO
BEGIN
IF LNGTH = 1 THEN TYPTR := CHARPTR
ELSE
BEGIN NEW(LSP,ARRAYS);
WITH LSP↑ DO
BEGIN AELTYPE := CHARPTR; FORM:=ARRAYS;
INXTYPE := NIL; SIZE := LNGTH*CHARSIZE
END;
TYPTR := LSP
END;
KIND := CST; CVAL := VAL
END;
INSYMBOL
END;
(*(*) LPARENT:
BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]);
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END;
(*NOT*) NOTSY:
BEGIN INSYMBOL; FACTOR(FSYS);
LOAD; GEN0(19(*NOT*));
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN
BEGIN ERROR(135); GATTR.TYPTR := NIL END;
END;
(*[*) LBRACK:
BEGIN INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
NEW(LSP,POWER);
WITH LSP↑ DO
BEGIN ELSET:=NIL;SIZE:=SETSIZE;FORM:=POWER END;
IF SY = RBRACK THEN
BEGIN
WITH GATTR DO
BEGIN TYPTR := LSP; KIND := CST END;
INSYMBOL
END
ELSE
BEGIN
REPEAT EXPRESSION(FSYS + [COMMA,COLON,RBRACK]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN
BEGIN ERROR(136); GATTR.TYPTR := NIL END
ELSE
IF COMPTYPES(LSP↑.ELSET,GATTR.TYPTR) THEN
BEGIN
IF GATTR.KIND = CST THEN
BEGIN
IF (GATTR.CVAL.IVAL < 0) THEN
ERROR(304)
ELSE
CSTPART :=CSTPART+[GATTR.CVAL.IVAL];
IF SY = COLON THEN (*RANGE GIVEN*)
BEGIN INSYMBOL ; LATTR := GATTR ;
EXPRESSION(FSYS+[COMMA,RBRACK]) ;
IF GATTR.TYPTR <> LATTR.TYPTR THEN
ERROR(137)
ELSE
FOR I := LATTR.CVAL.IVAL TO
GATTR.CVAL.IVAL DO
CSTPART := CSTPART+[I] ;
END (* IF SY = COLON *) ;
IF GATTR.CVAL.IVAL > SETRANGE THEN
ERROR(304) ;
END (* GATTR.KIND = CST *)
ELSE
BEGIN LOAD;
IF NOT COMPTYPES(GATTR.TYPTR,INTPTR)
THEN GEN0(61(*ORD*));
IF DEBUG THEN
GEN3(45(*CHK*),ORD('S'),0,SETRANGE);
GEN0(23(*SGS*));
IF VARPART THEN GEN0(28(*UNI*))
ELSE VARPART := TRUE
END;
LSP↑.ELSET := GATTR.TYPTR;
GATTR.TYPTR := LSP
END
ELSE ERROR(137);
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12)
END;
IF VARPART THEN
BEGIN
IF CSTPART <> [ ] THEN
BEGIN NEW(LVP,PSET); LVP↑.PVAL := CSTPART;
%LVP↑.CCLASS := PSET;\
CSTPTR := LVP;
GEN2(51(*LDC*),5,0);
GEN0(28(*UNI*)); GATTR.KIND := EXPR
END
END
ELSE
BEGIN NEW(LVP,PSET); LVP↑.PVAL := CSTPART;
%LVP↑.CCLASS := PSET;\
GATTR.CVAL.VALP := LVP
END
END
END (*CASE*) ;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS + FACBEGSYS) END
END (*WHILE*)
END (*FACTOR*) ;
BEGIN (*TERM*)
FACTOR(FSYS + [MULOP]);
WHILE SY = MULOP DO
BEGIN LOAD; LATTR := GATTR; LOP := OP;
INSYMBOL; FACTOR(FSYS + [MULOP]); LOAD;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
CASE LOP OF
(***) MUL: IF (LATTR.TYPTR=INTPTR)AND(GATTR.TYPTR=INTPTR)
THEN GEN0(15(*MPI*))
ELSE
BEGIN
IF GATTR.TYPTR = INTPTR THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END
ELSE
IF LATTR.TYPTR = INTPTR THEN
BEGIN GEN0(9(*FLO*));
LATTR.TYPTR := REALPTR
END;
IF (LATTR.TYPTR = REALPTR)
AND(GATTR.TYPTR=REALPTR)THEN GEN0(16(*MPR*))
ELSE
IF(LATTR.TYPTR↑.FORM=POWER)
AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)THEN
GEN0(12(*INT*))
ELSE BEGIN ERROR(134);GATTR.TYPTR:=NIL END
END;
(*/*) RDIV: BEGIN
IF GATTR.TYPTR = INTPTR THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END;
IF LATTR.TYPTR = INTPTR THEN
BEGIN GEN0(9(*FLO*));
LATTR.TYPTR := REALPTR
END;
IF (LATTR.TYPTR = REALPTR)
AND (GATTR.TYPTR=REALPTR)THEN GEN0(7(*DVR*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END;
(*DIV*) IDIV: IF (LATTR.TYPTR = INTPTR)
AND (GATTR.TYPTR = INTPTR) THEN GEN0(6(*DVI*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END;
(*MOD*) IMOD: IF (LATTR.TYPTR = INTPTR)
AND (GATTR.TYPTR = INTPTR) THEN GEN0(14 )
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END;
(*AND*) ANDOP:IF (LATTR.TYPTR = BOOLPTR)
AND (GATTR.TYPTR = BOOLPTR) THEN GEN0(4(*AND*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END (*CASE*)
ELSE GATTR.TYPTR := NIL
END (*WHILE*)
END (*TERM*) ;
BEGIN (*SIMPLEEXPRESSION*)
SIGNED := FALSE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN
BEGIN SIGNED := OP = MINUS; INSYMBOL END;
TERM(FSYS + [ADDOP]);
IF SIGNED THEN
BEGIN LOAD;
IF GATTR.TYPTR = INTPTR THEN GEN0(17(*NGI*))
ELSE
IF GATTR.TYPTR = REALPTR THEN GEN0(18(*NGR*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END;
WHILE SY = ADDOP DO
BEGIN LOAD; LATTR := GATTR; LOP := OP;
INSYMBOL; TERM(FSYS + [ADDOP]); LOAD;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
CASE LOP OF
(*+*) PLUS:
IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN
GEN0(2(*ADI*))
ELSE
BEGIN
IF GATTR.TYPTR = INTPTR THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END
ELSE
IF LATTR.TYPTR = INTPTR THEN
BEGIN GEN0(9(*FLO*));
LATTR.TYPTR := REALPTR
END;
IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR)
THEN GEN0(3(*ADR*))
ELSE IF(LATTR.TYPTR↑.FORM=POWER)
AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
GEN0(28(*UNI*))
ELSE BEGIN ERROR(134);GATTR.TYPTR:=NIL END
END;
(*-*) MINUS:
IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN
GEN0(21(*SBI*))
ELSE
BEGIN
IF GATTR.TYPTR = INTPTR THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END
ELSE
IF LATTR.TYPTR = INTPTR THEN
BEGIN GEN0(9(*FLO*));
LATTR.TYPTR := REALPTR
END;
IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR)
THEN GEN0(22(*SBR*))
ELSE
IF (LATTR.TYPTR↑.FORM = POWER)
AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
GEN0(5(*DIF*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END;
(*OR*) OROP:
IF(LATTR.TYPTR=BOOLPTR)AND(GATTR.TYPTR=BOOLPTR)THEN
GEN0(13(*IOR*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END (*CASE*)
ELSE GATTR.TYPTR := NIL
END (*WHILE*)
END (*SIMPLEEXPRESSION*) ;
BEGIN (*EXPRESSION*)
SIMPLEEXPRESSION(FSYS + [RELOP]);
IF SY = RELOP THEN
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <= POWER THEN LOAD
ELSE LOADADDRESS;
LATTR := GATTR; LOP := OP;
(*IN*) IF LOP = INOP THEN
BEGIN
IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN GEN0(61(*ORD*)) ;
IF DEBUG THEN GEN3(45(*CHK*),ORD('S'),0,SETRANGE) ;
END ;
INSYMBOL; SIMPLEEXPRESSION(FSYS);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <= POWER THEN LOAD
ELSE LOADADDRESS;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
IF LOP = INOP THEN
IF GATTR.TYPTR↑.FORM = POWER THEN
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR↑.ELSET) THEN
GEN0(11(*INN*))
ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END
ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END
ELSE
BEGIN
IF LATTR.TYPTR <> GATTR.TYPTR THEN
IF GATTR.TYPTR = INTPTR THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END
ELSE
IF LATTR.TYPTR = INTPTR THEN
BEGIN GEN0(9(*FLO*));
LATTR.TYPTR := REALPTR
END;
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN LSIZE := LATTR.TYPTR↑.SIZE;
CASE LATTR.TYPTR↑.FORM OF
SCALAR:
IF LATTR.TYPTR = REALPTR THEN TYPIND := 'R'
ELSE
IF LATTR.TYPTR = BOOLPTR THEN TYPIND := 'B'
ELSE
IF LATTR.TYPTR = CHARPTR THEN TYPIND := 'C'
ELSE TYPIND := 'I' ;
POINTER:
BEGIN
IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131);
TYPIND := 'A'
END;
POWER:
BEGIN IF LOP IN [LTOP,GTOP] THEN ERROR(132);
TYPIND := 'S'
END;
ARRAYS:
BEGIN
IF NOT STRING(LATTR.TYPTR)
AND(LOP IN[LTOP,LEOP,GTOP,GEOP])THEN ERROR(131);
TYPIND := 'M'
END;
RECORDS:
BEGIN
IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131);
TYPIND := 'M'
END;
FILES:
BEGIN ERROR(133); TYPIND := 'F' END
END;
CASE LOP OF
LTOP: GEN2(53(*LES*),ORD(TYPIND),LSIZE);
LEOP: GEN2(52(*LEQ*),ORD(TYPIND),LSIZE);
GTOP: GEN2(49(*GRT*),ORD(TYPIND),LSIZE);
GEOP: GEN2(48(*GEQ*),ORD(TYPIND),LSIZE);
NEOP: GEN2(55(*NEQ*),ORD(TYPIND),LSIZE);
EQOP: GEN2(47(*EQU*),ORD(TYPIND),LSIZE)
END
END
ELSE ERROR(129)
END;
GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR
END (*SY = RELOP*)
END (*EXPRESSION*) ;
PROCEDURE ASSIGNMENT(FCP: CTP);
VAR LATTR: ATTR;
%LCW 6JUN78\ SAVLFATTR, SAVRTATTR: ATTR;
%LCW 7JUN78\ LFALN, RTALN, ALN: ALNRNG;
%LCW 8JUN78\ TSTALN: INTEGER;
BEGIN
MODIFYING := TRUE ;
SELECTOR(FSYS + [BECOMES],FCP);
MODIFYING := FALSE ; VAR←MOD := VAR←MOD+1 ;
IF SY = BECOMES THEN
BEGIN
%LCW 6JUN78\ SAVLFATTR := GATTR;
IF GATTR.TYPTR <> NIL THEN
IF (GATTR.ACCESS<>DRCT) OR (GATTR.TYPTR↑.FORM>POWER) THEN
LOADADDRESS;
LATTR := GATTR;
INSYMBOL; EXPRESSION(FSYS);
%LCW 6JUN78\ SAVRTATTR := GATTR;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <= POWER THEN LOAD
ELSE LOADADDRESS;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
BEGIN
IF COMPTYPES(REALPTR,LATTR.TYPTR)AND(GATTR.TYPTR=INTPTR)THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END;
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN
IF DEBUG THEN
BEGIN
ASSIGN := TRUE ; CHKBNDS(LATTR.TYPTR); ASSIGN := FALSE
END ;
%LCW 7JUN78\ (*NOTE: MXDATASZE HERE IS ALSO THE MAX ALIGNMENT*)
%LCW 7JUN78\ (*WHICH CAN BE KNOWN FOR AN OPERAND ADDRESS*)
%LCW 7JUN78\ TSTALN := 2;
%LCW 7JUN78\ RTALN := 1;
%LCW 7JUN78\ LFALN := 1;
%LCW 7JUN78\ WHILE TSTALN <= MXDATASZE DO
%LCW 7JUN78\ BEGIN
%LCW 7JUN78\ IF (SAVRTATTR.ACCESS = DRCT)
%LCW 7JUN78\ AND ((SAVRTATTR.DPLMT MOD TSTALN) = 0) THEN
%LCW 7JUN78\ RTALN := TSTALN;
%LCW 7JUN78\ IF (SAVLFATTR.ACCESS = DRCT)
%LCW 7JUN78\ AND ((SAVLFATTR.DPLMT MOD TSTALN) = 0) THEN
%LCW 7JUN78\ LFALN := TSTALN;
%LCW 7JUN78\ TSTALN := TSTALN*2;
%LCW 7JUN78\ END;
%LCW 6JUN78\ IF LFALN < RTALN
%LCW 6JUN78\ THEN ALN := LFALN ELSE ALN := RTALN;
%LCW 6JUN78\ IF LATTR.TYPTR↑.ALN > ALN
%LCW 6JUN78\ THEN ALN := LATTR.TYPTR↑.ALN;
CASE LATTR.TYPTR↑.FORM OF
SCALAR,
SUBRANGE,
POINTER,
POWER: STORE(LATTR);
ARRAYS,
%LCW 5JUN78\ RECORDS: GEN2(40(*MOV*),LATTR.TYPTR↑.SIZE,ALN);
FILES: ERROR(146)
END (*CASE LATTR...*)
END
ELSE ERROR(129)
END
END (*SY = BECOMES*)
ELSE ERROR(51)
END (*ASSIGNMENT*) ;
PROCEDURE GOTOSTATEMENT;
VAR LLP: LBP; FOUND: BOOLEAN; TTOP,TTOP1: DISPRANGE;
BEGIN
IF SY = INTCONST THEN
BEGIN
FOUND := FALSE; TTOP := TOP;
WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP - 1;
TTOP1 := TTOP;
REPEAT
LLP := DISPLAY[TTOP].FLABEL;
WHILE (LLP <> NIL) AND NOT FOUND DO
WITH LLP↑ DO
IF LABVAL = VAL.IVAL THEN
BEGIN FOUND := TRUE;
IF TTOP = TTOP1 THEN
BEGIN
GENUJPFJP(57(*UJP*),LABNAME) ;
%CTR\ CTREMIT(CTRGOTO, 0, LINECOUNT, 0, LINECOUNT)
END
ELSE (*GOTO LEADS OUT OF PROCEDURE*) ERROR(398)
END
ELSE LLP := NEXTLAB;
TTOP := TTOP - 1
UNTIL FOUND OR (TTOP = 0);
IF NOT FOUND THEN ERROR(167);
INSYMBOL
END
ELSE ERROR(15)
END (*GOTOSTATEMENT*) ;
PROCEDURE COMPOUNDSTATEMENT;
BEGIN
REPEAT
REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY])
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END (*COMPOUNDSTATEMENET*) ;
PROCEDURE IFSTATEMENT;
VAR LCIX1,LCIX2: INTEGER;
%CTR\ FIRSTLN, MIDLN : INTEGER; CTRNO : CTRRANGE;
BEGIN EXPRESSION(FSYS + [THENSY]);
GENLABEL(LCIX1); GENFJP(LCIX1);
IF SY = THENSY THEN INSYMBOL ELSE ERROR(52);
%CTR\ FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
%CTR\ (*** COUNTER HERE ***)
STATEMENT(FSYS + [ELSESY]);
IF SY = ELSESY THEN
BEGIN GENLABEL(LCIX2); GENUJPFJP(57(*UJP*),LCIX2);
PUTLABEL(LCIX1);
INSYMBOL;
%CTR\ MIDLN := LINECOUNT ;
STATEMENT(FSYS);
PUTLABEL(LCIX2)
END
ELSE
BEGIN
PUTLABEL(LCIX1) ;
%CTR\ MIDLN := 0;
END ;
%CTR\ CTREMIT(CTRIF, CTRNO, FIRSTLN, MIDLN, LINECOUNT)
END (*IFSTATEMENT*) ;
PROCEDURE CASESTATEMENT;
LABEL 1;
TYPE CIP = ↑CASEINFO;
CASEINFO = PACKED
RECORD NEXT: CIP;
CSSTART: INTEGER;
CSLAB: INTEGER
END;
VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL: VALU;
LADDR, LCIX, LCIX1, LMIN, LMAX, UBND, LBND: ADDRRANGE ;
%CTR\ FIRSTLN : INTEGER; TEMPLN : INTEGER;
%CTR\ CTRCASES : INTEGER; CTRNO : CTRRANGE;
BEGIN EXPRESSION(FSYS + [OFSY,COMMA,COLON]);
LOAD ; % ALIGN(LC,INTSIZE) ; LLC := LC ; \
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN
IF (LSP↑.FORM <> SCALAR) OR (LSP = REALPTR) THEN
BEGIN ERROR(144); LSP := NIL END
ELSE IF NOT COMPTYPES(LSP,INTPTR) THEN GEN0(61(*ORD*)) ;
IF DEBUG THEN CHKBNDS(GATTR.TYPTR) ;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
FSTPTR := NIL ; GENLABEL(LBND) ; GENLABEL(UBND) ;
GENLABEL(LCIX) ; GENLABEL(LADDR);
(* WE SHOULD HAVE: LADDR = LCIX+1 = UBND+2 = LBND+3 HERE *)
GENUJPFJP(44 (*XJP*), LBND) ; %GENCASE(LBND,UBND,LCIX) ; \
%CTR\ FIRSTLN := LINECOUNT; CTRCASES := 0;
REPEAT
LPT3 := NIL; GENLABEL(LCIX1);
IF NOT(SY IN [SEMICOLON,ENDSY]) THEN
BEGIN
REPEAT CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL);
IF LSP <> NIL THEN
IF COMPTYPES(LSP,LSP1) THEN
BEGIN LPT1 := FSTPTR; LPT2 := NIL;
WHILE LPT1 <> NIL DO
WITH LPT1↑ DO
BEGIN
IF CSLAB <= LVAL.IVAL THEN
BEGIN IF CSLAB = LVAL.IVAL THEN ERROR(156);
GOTO 1
END;
LPT2 := LPT1; LPT1 := NEXT
END;
1: NEW(LPT3);
WITH LPT3↑ DO
BEGIN NEXT := LPT1; CSLAB := LVAL.IVAL;
CSSTART := LCIX1
END;
IF LPT2 = NIL THEN FSTPTR := LPT3
ELSE LPT2↑.NEXT := LPT3
END
ELSE ERROR(147);
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
PUTLABEL(LCIX1);
%CTR\ TEMPLN := LINECOUNT; (*** COUNTER HERE ***)
%CTR\ CTRNO := CTRGEN; CTRCASES := CTRCASES+1 ;
REPEAT STATEMENT(FSYS + [SEMICOLON])
UNTIL NOT (SY IN STATBEGSYS);
IF LPT3 <> NIL THEN
GENUJPFJP(57(*UJP*),LADDR);
END ;
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL ;
%CTR\ CTREMIT(CTRCASE, CTRNO, TEMPLN, 0, LINECOUNT);
UNTIL TEST;
IF FSTPTR <> NIL THEN
BEGIN LMAX := FSTPTR↑.CSLAB;
(*REVERSE POINTERS*)
LPT1 := FSTPTR; FSTPTR := NIL;
REPEAT LPT2 := LPT1↑.NEXT; LPT1↑.NEXT := FSTPTR;
FSTPTR := LPT1; LPT1 := LPT2
UNTIL LPT1 = NIL;
LMIN := FSTPTR↑.CSLAB;
GENDEF(LBND,LMIN) ; GENDEF(UBND,LMAX) ; PUTLABEL(LCIX) ;
IF LMAX - LMIN < CIXMAX THEN
BEGIN
REPEAT
WITH FSTPTR↑ DO
BEGIN
WHILE CSLAB > LMIN DO
BEGIN GENUJPFJP(57(*UJP*),LADDR); LMIN:=LMIN+1 END;
GENUJPFJP(57(*UJP*),CSSTART);
FSTPTR := NEXT; LMIN := LMIN + 1
END
UNTIL FSTPTR = NIL;
PUTLABEL(LADDR) ;
%CTR\ CTREMIT(CTRCASE, 0, FIRSTLN, CTRCASES, LINECOUNT);
END
ELSE ERROR(157)
END;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END (*CASESTATEMENT*) ;
PROCEDURE REPEATSTATEMENT;
VAR LADDR: INTEGER;
%CTR\ FIRSTLN : INTEGER; CTRNO : CTRRANGE;
BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
%CTR\ FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
%CTR\ (*** COUNTER HERE ***)
REPEAT
REPEAT STATEMENT(FSYS + [SEMICOLON,UNTILSY])
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = UNTILSY THEN
BEGIN INSYMBOL; EXPRESSION(FSYS); GENFJP(LADDR) ;
%CTR\ CTREMIT(CTRREPEAT, CTRNO, FIRSTLN, 0, LINECOUNT)
END
ELSE ERROR(53)
END (*REPEATSTATEMENT*) ;
PROCEDURE WHILESTATEMENT;
VAR LADDR, LCIX: INTEGER;
%CTR\ FIRSTLN : INTEGER; CTRNO : CTRRANGE;
BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
EXPRESSION(FSYS + [DOSY]); GENLABEL(LCIX); GENFJP(LCIX);
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
%CTR\ FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
(*** COUNTER HERE ***)
STATEMENT(FSYS); GENUJPFJP(57(*UJP*),LADDR); PUTLABEL(LCIX) ;
%CTR\ CTREMIT(CTRWHILE, CTRNO, FIRSTLN, 0, LINECOUNT);
END (*WHILESTATEMENT*) ;
PROCEDURE FORSTATEMENT;
VAR LATTR: ATTR; LSP: STP; LSY: SYMBOL;
LCIX, LADDR: LABELRNG ; LLC : ADDRRANGE ;
%CTR\ FIRSTLN : INTEGER; CTRNO : CTRRANGE;
BEGIN
IF SY = IDENT THEN
BEGIN SEARCHID([VARS],LCP);
WITH LCP↑, LATTR DO
BEGIN TYPTR := IDTYPE; KIND := VARBL; BTYPE := TYPTR ;
IF VKIND = ACTUAL THEN
BEGIN ACCESS := DRCT; VLEVEL := VLEV;
DPLMT := VADDR ;
IF GET←STAT THEN
WRITE(QRR, ' MOD', CHR( GETTYPE(BTYPE) ), ' ':2,
' DIR', VLEVEL:3, DPLMT:8, ' MND ' ) ;
END
ELSE BEGIN ERROR(155); TYPTR := NIL END
END;
IF LATTR.TYPTR <> NIL THEN
IF (LATTR.TYPTR↑.FORM > SUBRANGE)
OR COMPTYPES(REALPTR,LATTR.TYPTR) THEN
BEGIN ERROR(143); LATTR.TYPTR := NIL END;
INSYMBOL
END
ELSE
BEGIN ERROR(2); SKIP(FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY]) END;
IF SY = BECOMES THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + [TOSY,DOWNTOSY,DOSY]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(144)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN LOAD;
IF DEBUG THEN CHKBNDS(LATTR.TYPTR) ; STORE(LATTR) ;
END
ELSE ERROR(145)
END
ELSE
BEGIN ERROR(51); SKIP(FSYS + [TOSY,DOWNTOSY,DOSY]) END;
IF SY IN [TOSY,DOWNTOSY] THEN
BEGIN LSY := SY; INSYMBOL; EXPRESSION(FSYS + [DOSY]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(144)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN LOAD; IF DEBUG THEN CHKBNDS(LATTR.TYPTR) ;
ALIGN(LC,INTSIZE) ; LLC := LC ;
GEN3(56(*STR*),ORD('I'),LEVEL,LLC);
GATTR := LATTR; LOAD;
GEN3(54(*LOD*),ORD('I'),LEVEL,LLC);
LC := LC + INTSIZE;
IF LC > LCMAX THEN LCMAX := LC;
IF LSY = TOSY THEN GEN2(52(*LEQ*),ORD('I'),1)
ELSE GEN2(48(*GEQ*),ORD('I'),1);
END
ELSE ERROR(145)
END
ELSE BEGIN ERROR(55); SKIP(FSYS + [DOSY]) END;
GENLABEL(LADDR) ; GENLABEL(LCIX); GENUJPFJP(33(*FJP*),LCIX);
PUTLABEL(LADDR) ; (*BEGINNING OF THE FOR 'LOOP'*)
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
%CTR\ FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
(*** COUNTER HERE ***)
STATEMENT(FSYS);
GATTR := LATTR ; LOAD ;
GEN3(54(*LOD*),ORD('I'),LEVEL,LLC) ;
GEN2(55(*NEQ*),ORD('I'),1) ; GENUJPFJP(33(*FJP*),LCIX) ;
GATTR := LATTR; LOAD;
IF LSY = TOSY THEN GEN2(34(*INC*),GETTYPE(GATTR.BTYPE),1)
ELSE GEN2(31(*DEC*),GETTYPE(GATTR.BTYPE),1);
IF DEBUG THEN CHKBNDS(LATTR.TYPTR) ;
STORE(LATTR); GENUJPFJP(57(*UJP*),LADDR); PUTLABEL(LCIX);
LC := LLC ;
%CTR\ CTREMIT(CTRFOR, CTRNO, FIRSTLN, 0, LINECOUNT);
END (*FORSTATEMENT*) ;
PROCEDURE WITHSTATEMENT;
VAR LCP: CTP; LCNT: DISPRANGE; LLC: ADDRRANGE;
BEGIN LCNT := TOP ; LLC := LC ;
REPEAT
IF SY = IDENT THEN
BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END
ELSE BEGIN ERROR(2); LCP := UVARPTR END;
SELECTOR(FSYS + [COMMA,DOSY],LCP);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM = RECORDS THEN
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN FNAME := GATTR.TYPTR↑.FSTFLD;
FLABEL := NIL
END;
IF GATTR.ACCESS = DRCT THEN
WITH DISPLAY[TOP] DO
BEGIN OCCUR := CREC; CLEV := GATTR.VLEVEL;
CDSPL := GATTR.DPLMT
END
ELSE
BEGIN LOADADDRESS; ALIGN(LC,PTRSIZE) ;
GEN3(56(*STR*),ORD('A'),LEVEL,LC);(*=GETTYPE(GAT.TYP)*)
WITH DISPLAY[TOP] DO
BEGIN OCCUR := VREC; VDSPL := LC END;
LC := LC + PTRSIZE;
IF LC > LCMAX THEN LCMAX := LC
END
END
ELSE ERROR(250)
ELSE ERROR(140);
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
STATEMENT(FSYS);
TOP := LCNT ; LC := LLC ;
END (*WITHSTATEMENT*) ;
BEGIN (*STATEMENT*)
IF SY = INTCONST THEN (*LABEL*)
BEGIN TTOP := TOP ;
WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP-1 ;
LLP := DISPLAY[TTOP].FLABEL;
WHILE LLP <> NIL DO
WITH LLP↑ DO
IF LABVAL = VAL.IVAL THEN
BEGIN IF DEFINED THEN ERROR(165);
PUTLABEL(LABNAME); DEFINED := TRUE;
%CTR\ CTRNO := CTRGEN;
%CTR\ CTREMIT(CTRLBL, CTRNO, LINECOUNT, 0, LINECOUNT);
%CTR\ (*** COUNTER HERE ***)
GOTO 1
END
ELSE LLP := NEXTLAB;
ERROR(167);
1: INSYMBOL;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5)
END;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS) END;
IF SY IN STATBEGSYS + [IDENT] THEN
BEGIN
CASE SY OF
IDENT: BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
IF LCP↑.KLASS = PROC THEN CALL(FSYS,LCP)
ELSE ASSIGNMENT(LCP)
END;
BEGINSY: BEGIN INSYMBOL; COMPOUNDSTATEMENT END;
GOTOSY: BEGIN INSYMBOL; GOTOSTATEMENT END;
IFSY: BEGIN INSYMBOL; IFSTATEMENT END;
CASESY: BEGIN INSYMBOL; CASESTATEMENT END;
WHILESY: BEGIN INSYMBOL; WHILESTATEMENT END;
REPEATSY: BEGIN INSYMBOL; REPEATSTATEMENT END;
FORSY: BEGIN INSYMBOL; FORSTATEMENT END;
WITHSY: BEGIN INSYMBOL; WITHSTATEMENT END
END;
IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY]) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
END (*STATEMENT*) ;
BEGIN (*BODY*)
IF FPROCP <> NIL THEN
BEGIN ENTNAME := FPROCP↑.PFNAME ; PROCNAME := FPROCP↑.NAME ; END
ELSE PROCNAME := '$MAINBLK ' ;
GENCUPENT(32(*ENT*),PROCTYPE(FPROCP),SEGSIZE,ENTNAME,PROCNAME) ;
NEW(CALL←HEAD) ;
CALL←HEAD↑.NAME := BLANK12 ; CALL←HEAD↑.NXT := NIL ;
LOCAL←CALL := FALSE ; MODIFYING := FALSE ;
VAR←REF := 0 ; VAR←MOD := 0 ;
WRITELN(QRR, ' BGN ', PROCNAME, LEVEL:4) ;
IF FPROCP = NIL THEN (* ENTERING MAIN BLOCK *)
BEGIN
SAVEID := ID;
WHILE FEXTFILEP <> NIL DO
BEGIN
WITH FEXTFILEP↑ DO
BEGIN ID := FILENAME;
PRTERR := FALSE ; SEARCHID([VARS],LLCP); PRTERR := TRUE ;
IF LLCP <> NIL THEN
IF LLCP↑.IDTYPE↑.FORM <> FILES THEN
LLCP := NIL;
IF LLCP = NIL THEN
BEGIN
WRITELN('**** UNDECLARED EXTERNAL FILE:':40, ID:10);
ERROR(398) ;
END
ELSE (* OPEN THE FILES REQUESTED ABOVE *)
WITH LLCP↑ DO
BEGIN
IF GEBCDFIL THEN GEN2(50(*LDA*),1,VADDR+1000)
ELSE GEN2(50(*LDA*),1,VADDR) ;
GEN1(30(*CSP*),29(*SIO*)) ;
IF ODD(VADDR) THEN GEN1(30(*CSP*),4(*REW*))
ELSE GEN1(30(*CSP*),3(*RES*)) ;
GEN1(30(*CSP*),30(*EIO*)) ;
END ;
END;
FEXTFILEP := FEXTFILEP↑.NEXTFILE
END;
ID := SAVEID;
%CTR\ IF CTROPTION THEN
%CTR\ BEGIN
%CTR\ GENLABEL(CTRCNTLBL) ; GENUJPFJP(38(*CTS*), CTRCNTLBL) ;
%CTR\ END ;
END (* PROCESSING MAIN BLOCK *)
ELSE (* FPROCP <> NIL ==> COPY MULTIPLE VALUES INTO LOCAL CELLS*)
BEGIN LLC1 := LCAFTMST ;
IF FPROCP↑.SAVEFP THEN LLC1 := LCAFTMST+FPSAVEAREA ;
LCP := FPROCP↑.NEXT;
WHILE LCP <> NIL DO
WITH LCP↑ DO
BEGIN
IF KLASS = VARS THEN
IF IDTYPE <> NIL THEN
IF VKIND = FORMAL THEN (* VAR PARAMETER *)
BEGIN ALIGN(LLC1,PTRSIZE) ;
LLC1 := LLC1+PTRSIZE ;
END
ELSE (* VKIND = ACTUAL *)
IF IDTYPE↑.FORM > POWER THEN
BEGIN
ALIGN(LLC1,PTRSIZE) ;
GEN2(50(*LDA*),LEVEL,VADDR);
GEN3(54(*LOD*),ORD('A'),LEVEL,LLC1);
%LCW 5JUN78\ GEN2(40(*MOV*),IDTYPE↑.SIZE,IDTYPE↑.ALN);
LLC1 := LLC1 + PTRSIZE
END
ELSE (* FORM <= POWER *)
BEGIN
ALIGN(LLC1,IDTYPE↑.ALN) ; LLC1 := LLC1 + IDTYPE↑.SIZE ;
END ;
LCP := LCP↑.NEXT;
END;
END;
%CTR\ FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
%CTR\ (*** COUNTER HERE ***)
LCMAX := LC;
(* COMPILE THE STATEMENTS WITHIN THIS BLOCK (BODY) *)
REPEAT
REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY])
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13);
LLP := DISPLAY[TOP].FLABEL; (*TEST FOR UNDEFINED LABELS*)
WHILE LLP <> NIL DO
WITH LLP↑ DO
BEGIN
IF NOT DEFINED THEN
BEGIN
WRITELN(OUTPUT,'**** UNDEF. LABEL:':28,LABVAL); ERROR(168) ;
END;
LLP := NEXTLAB
END;
%CTR\ CTREMIT(CTRPROC, CTRNO, FIRSTLN, 0, LINECOUNT);
%CTR\ IF FPROCP = NIL THEN (* RESET COUNTERS *)
%CTR\ BEGIN
%CTR\ CTREMIT(CTRPROC, 0, 0, 0, 0); (* EOF FOR COUNTER TABLE *)
%CTR\ IF ODD(CTRCNT) THEN CTRCNT := CTRCNT+1 ;
%CTR\ IF CTROPTION THEN GENDEF(CTRCNTLBL, CTRCNT) ;
%CTR\ END ;
GEN1(42(*RET*),PROCTYPE(FPROCP)); ALIGN(LCMAX,MXDATASZE) ;PRTIC := FALSE ;
IF PRCODE THEN
BEGIN GENDEF(SEGSIZE,LCMAX) ;
IF FPROCP = NIL THEN GEN0(29(*STP*) ) ;
END ;
%IF (FPROCP = NIL) AND PRTABLES THEN PRINTTABLES(TRUE) \
CALL←LVL[LOCAL←CALL] := CALL←LVL[LOCAL←CALL]+1 ;
WRITELN(QRR) ;
WRITE(QRR, ' PROC ':8, PROCNAME:8, LOCAL←CALL:4, IC:6, LCMAX:10,
' REF./MOD. RATIO:', VAR←MOD:4, VAR←MOD+VAR←REF:6) ;
IF (VAR←MOD+VAR←REF) = 0 THEN WRITELN(QRR,0.0:10)
ELSE WRITELN(QRR, VAR←MOD/(VAR←MOD+VAR←REF):10) ;
WHILE CALL←HEAD↑.NXT <> NIL DO
BEGIN
WRITE(QRR, ' ', CALL←HEAD↑.NAME, CALL←HEAD↑.LVL:3, CALL←HEAD↑.CNT: 4);
CALL←HEAD := CALL←HEAD↑.NXT ;
END ;
WRITELN(QRR) ; WRITELN(QRR, ' END') ;
OLDIC := OLDIC+ IC ; IC := 0 ; (* RESET IC FOR NEXT PROC *)
END (*BODY*) ;
%S1\
%S1\ PROCEDURE MKNAME(VAR ALB: ALPHA; NLB: INTEGER ) ;
%S1\ VAR I, J: INTEGER ;
%S1\
%S1\ BEGIN
%S1\ I := 1 ;
%S1\ WHILE (I < 6) AND (ALB[I] <> ' ') DO
%S1\ BEGIN IF ALB[I] = '←' THEN ALB[I] := '$' ; I := I+1 END ;
%S1\ FOR J := 8 DOWNTO I DO
%S1\ BEGIN
%S1\ ALB[J] := CHR( ORD('0')+ NLB MOD 10 ) ;
%S1\ NLB := NLB DIV 10 ;
%S1\ END ;
%S1\ END (*MKNAME*) ;
BEGIN (*BLOCK*)
% DP := TRUE;\ GENLABEL(SEGSIZE) ;
REPEAT
IF SY = LABELSY THEN
BEGIN INSYMBOL; LABELDECLARATION END;
IF SY = CONSTSY THEN
BEGIN INSYMBOL; CONSTDECLARATION END;
IF SY = TYPESY THEN
BEGIN INSYMBOL; TYPEDECLARATION END;
IF SY = VARSY THEN
BEGIN INSYMBOL; VARDECLARATION END;
%S1\
%S1\ WRITE(PRR, ' SST ', CHR( PROCTYPE(FPROCP) ):1, ' ') ;
%S1\ IF FPROCP = NIL THEN
%S1\ WRITELN(PRR, '$MAINBLK', 1:3, 0:4, 0:4, LC-LASTFILBUF:8, 0:4)
%S1\ ELSE
%S1\ WITH FPROCP↑ DO
%S1\ BEGIN ID := NAME ; MKNAME(ID, PFNAME) ; ALIGN(LC,MXDATASZE) ;
%S1\ WRITELN(PRR, ID:8, PFLEV+1:3, FPRMSZE:8, SPRMSZE:8,
%S1\ LC-LCAFTMST-FPRMSZE-SPRMSZE:8, RPRMSZE:8) ;
%S1\ END ;
%S1\
WHILE SY IN [PROCSY,FUNCSY] DO
BEGIN LSY := SY; INSYMBOL; PROCDECLARATION(LSY) END;
IF SY <> BEGINSY THEN
BEGIN ERROR(18); SKIP(FSYS) END
UNTIL SY IN STATBEGSYS;
DP := FALSE;
IF SY = BEGINSY THEN INSYMBOL ELSE ERROR(17);
REPEAT BODY(FSYS + [CASESY]);
IF SY <> FSY THEN
BEGIN ERROR(6); SKIP(FSYS + [FSY]) END
UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS);
DP := TRUE ;
END (*BLOCK*) ;
PROCEDURE PROGRAMME(FSYS:SETOFSYS);
VAR EXTFP:EXTFILEP;
BEGIN
REWRITE(QRR) ; (* USED FOR EXTRA INFO ABOUT PROGRAM *)
CALL←LVL[FALSE] := 0 ; CALL←LVL[TRUE] := 0 ;
IF SY = PROGSY THEN
BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2); INSYMBOL;
IF NOT (SY IN [LPARENT,SEMICOLON]) THEN ERROR(14);
IF SY = LPARENT THEN
BEGIN
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(EXTFP);
WITH EXTFP↑ DO
BEGIN FILENAME := ID; NEXTFILE := FEXTFILEP ;
GEBCDFIL := EBCDFLG ; EBCDFLG := FALSE
END;
FEXTFILEP := EXTFP;
INSYMBOL;
IF NOT ( SY IN [COMMA,RPARENT] ) THEN ERROR(20)
END
ELSE ERROR(2)
UNTIL SY <> COMMA;
IF SY <> RPARENT THEN ERROR(4);
INSYMBOL
END;
IF SY <> SEMICOLON THEN ERROR(14)
ELSE INSYMBOL;
END;
REPEAT BLOCK(FSYS,PERIOD,NIL);
IF SY <> PERIOD THEN ERROR(21)
UNTIL SY = PERIOD ;
WRITELN(QRR,' HLT CALL←RATIO', CALL←LVL[TRUE]:4, CALL←LVL[FALSE]:4,
CALL←LVL[TRUE]+CALL←LVL[FALSE]:4) ;
IF ERRINX > 0 THEN PRINTERROR ;
END (*PROGRAMME*) ;
PROCEDURE STDNAMES;
BEGIN
NA[ 1] := 'FALSE '; NA[ 2] := 'TRUE ';
NA[ 5] := 'GET '; NA[ 6]:= 'PUT ';
NA[ 7] := 'RESET '; NA[ 8] := 'REWRITE '; NA[ 9]:= 'READ ';
NA[10] := 'WRITE '; NA[11] := 'PACK '; NA[12]:= 'UNPACK ';
NA[13] := 'NEW '; NA[14] := 'RELEASE '; NA[15]:= 'READLN ';
NA[16] := 'WRITELN '; NA[17] := 'MARK '; NA[18]:= 'TRAP ';
NA[20] := 'ABS '; NA[21] := 'SQR '; NA[22]:= 'TRUNC ';
NA[23] := 'ODD '; NA[24] := 'ORD '; NA[25]:= 'CHR ';
NA[26] := 'PRED '; NA[27] := 'SUCC '; NA[28]:= 'CLOCK ';
NA[29] := 'EOF '; NA[30] := 'EOLN ';
NA[31] := 'SIN '; NA[32] := 'COS '; NA[33]:= 'EXP ';
NA[34] := 'SQRT '; NA[35] := 'LN '; NA[36]:= 'ARCTAN ';
NA[37] := 'EXIT ';
NA[39] := 'INPUT '; NA[40] := 'OUTPUT '; NA[41]:= 'PRD ';
NA[42] := 'PRR '; NA[43] := 'QRD '; NA[44]:= 'QRR ';
END (*STDNAMES*) ;
PROCEDURE ENTERSTDTYPES;
VAR SP: STP;
BEGIN (*TYPE UNDERLIEING:*)
(*******************)
NEW(INTPTR,SCALAR,STANDARD); (*INTEGER*)
WITH INTPTR↑ DO
BEGIN SIZE := INTSIZE; ALN := INTSIZE ;
FORM := SCALAR; SCALKIND := STANDARD END;
NEW(REALPTR,SCALAR,STANDARD); (*REAL*)
WITH REALPTR↑ DO
BEGIN SIZE := REALSIZE; ALN := REALSIZE ; %LCW 5JUN78\
FORM := SCALAR; SCALKIND := STANDARD END;
NEW(CHARPTR,SCALAR,STANDARD); (*CHAR*)
WITH CHARPTR↑ DO
BEGIN SIZE := CHARSIZE; ALN := CHARSIZE ;
FORM := SCALAR; SCALKIND := STANDARD END;
NEW(BOOLPTR,SCALAR,DECLARED); (*BOOLEAN*)
WITH BOOLPTR↑ DO
BEGIN SIZE := BOOLSIZE; ALN := BOOLSIZE ;
FORM := SCALAR; SCALKIND := DECLARED END;
NEW(NILPTR,POINTER); (*NIL*)
WITH NILPTR↑ DO
BEGIN ELTYPE := NIL; SIZE := PTRSIZE; ALN := PTRSIZE ;
FORM := POINTER END;
NEW(TEXTPTR,FILES); (*TEXT*)
WITH TEXTPTR↑ DO
BEGIN FILTYPE := CHARPTR; SIZE := CHARSIZE; ALN := CHARSIZE ;
FORM := FILES END
END (*ENTERSTDTYPES*) ;
PROCEDURE ENTSTDNAMES;
VAR CP,CP1: CTP; I: INTEGER;
BEGIN (*NAME:*)
(*******)
NEW(CP,TYPES); (*INTEGER*)
WITH CP↑ DO
BEGIN NAME := 'INTEGER '; IDTYPE := INTPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*REAL*)
WITH CP↑ DO
BEGIN NAME := 'REAL '; IDTYPE := REALPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*CHAR*)
WITH CP↑ DO
BEGIN NAME := 'CHAR '; IDTYPE := CHARPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*BOOLEAN*)
WITH CP↑ DO
BEGIN NAME := 'BOOLEAN '; IDTYPE := BOOLPTR; KLASS := TYPES END;
ENTERID(CP);
CP1 := NIL;
FOR I := 1 TO 2 DO
BEGIN NEW(CP,KONST); (*FALSE,TRUE*)
WITH CP↑ DO
BEGIN NAME := NA[I]; IDTYPE := BOOLPTR;
NEXT := CP1; VALUES.IVAL := I - 1; KLASS := KONST
END;
ENTERID(CP); CP1 := CP
END;
BOOLPTR↑.FCONST := CP;
NEW(CP,KONST); (*NIL*)
WITH CP↑ DO
BEGIN NAME := 'NIL '; IDTYPE := NILPTR;
NEXT := NIL; VALUES.IVAL := 0; KLASS := KONST
END;
ENTERID(CP);
FOR I := 39 TO 44 DO
BEGIN NEW(CP,VARS); (*INPUT,OUTPUT*)
WITH CP↑ DO (*PRD,PRR*)
BEGIN NAME := NA[I]; IDTYPE := TEXTPTR; (*QRD,QRR*)
KLASS := VARS; VKIND := ACTUAL; NEXT := NIL; VLEV := 1;
VADDR := FIRSTFILBUF+(I-39)*CHARSIZE ; EBCD := FALSE ;
END;
ENTERID(CP)
END;
FOR I := 5 TO 18 DO
BEGIN NEW(CP,PROC,STANDARD); (*GET,PUT,RESET*)
WITH CP↑ DO (*REWRITE,READ*)
BEGIN NAME := NA[I]; IDTYPE := NIL; (*WRITE,PACK*)
NEXT := NIL; KEY := I - 4; (*UNPACK,PACK*)
KLASS := PROC; PFDECKIND := STANDARD (*READLN,WRITELN*)
END; (*MARK,RELEASE*)
ENTERID(CP) (*TRAP*)
END;
FOR I := 20 TO 30 DO
BEGIN NEW(CP,FUNC,STANDARD); (*ABS,SQR,TRUNC*)
WITH CP↑ DO (*ODD,ORD,CHR*)
BEGIN NAME := NA[I]; IDTYPE := NIL; (*PRED,SUCC*)
NEXT := NIL; KEY := I - 19; (*CLOCK,EOF,EOLN *)
KLASS := FUNC; PFDECKIND := STANDARD
END;
ENTERID(CP)
END;
NEW(CP,VARS); (*PARAMETER OF PREDECLARED FUNCTIONS*)
WITH CP↑ DO
BEGIN NAME := BLANK12; IDTYPE := REALPTR; KLASS := VARS;
VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 0
END;
FOR I := 31 TO 37 DO
BEGIN NEW(CP1,FUNC,DECLARED,ACTUAL); (*SIN,COS,EXP,SQRT*)
WITH CP1↑ DO (*LN,ARCTAN,EXIT*)
BEGIN NAME := NA[I]; IDTYPE := REALPTR; NEXT := CP;
FORWDECL := FALSE; XTERN := TRUE; PFLEV := 0; PFNAME := I - 16;
KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END;
ENTERID(CP1)
END;
NEW(CP,VARS); (*PARAMETER OF EXIT ROUTINE*)
WITH CP↑ DO
BEGIN NAME := BLANK12; IDTYPE := INTPTR; KLASS := VARS;
VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 0
END;
WITH CP1↑ DO (*FIXUPS FOR EXIT PROCEDURE*)
BEGIN IDTYPE := NIL; NEXT := CP; KLASS := PROC END;
END (*ENTSTDNAMES*) ;
PROCEDURE ENTERUNDECL;
VAR TMPLABEL:INTEGER;
BEGIN
NEW(UTYPPTR,TYPES);
WITH UTYPPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; KLASS := TYPES END;
NEW(UCSTPTR,KONST);
WITH UCSTPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; NEXT := NIL;
VALUES.IVAL := 0; KLASS := KONST
END;
NEW(UVARPTR,VARS);
WITH UVARPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; VKIND := ACTUAL;
NEXT := NIL; VLEV := 0; VADDR := 0; KLASS := VARS
END;
NEW(UFLDPTR,FIELD);
WITH UFLDPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
KLASS := FIELD
END;
NEW(UPRCPTR,PROC,DECLARED,ACTUAL);
WITH UPRCPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; FORWDECL := FALSE;
NEXT := NIL; XTERN := FALSE; PFLEV := 0; GENLABEL(TMPLABEL);
PFNAME := TMPLABEL;
KLASS := PROC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END;
NEW(UFCTPTR,FUNC,DECLARED,ACTUAL);
WITH UFCTPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; NEXT := NIL;
FORWDECL := FALSE; XTERN := FALSE; PFLEV := 0; GENLABEL(TMPLABEL);
PFNAME := TMPLABEL;
KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END
END (*ENTERUNDECL*) ;
PROCEDURE INITSCALARS;
BEGIN FWPTR := NIL;
PRTABLES := FALSE; LIST := TRUE; PRCODE := TRUE;
DP := TRUE; PRTERR := TRUE; ERRINX := 0;
INTLABEL := 0; KK := IDLNGTH; FEXTFILEP := NIL;
LC := LASTFILBUF ; (*ADR. OF THE FIRST VARIABLE OF 'MAIN BLOCK'*)
(* NOTE IN THE ABOVE RESERVATION OF BUFFER STORE FOR TEXT FILES *)
OLDIC := 0; IC := 0 ; EOL := TRUE; LINECOUNT := 0;
CH := ' '; CHCNT := 0;
GLOBTESTP := NIL;
MXINT10 := MAXINT DIV 10; %DIGMAX := REALLNGTH - 1;\
PROCLAB := 0; ERRORCOUNT :=0 ; ASSEMBLE:= FALSE; MARGIN := TRUE ;
SAVEREGS := TRUE ; SAVEFPRS := TRUE ; EBCDFLG := FALSE ;
DEBUG := FALSE ; BYTEON := FALSE ; ASSIGN := FALSE ;
NXTFILBUF := FIRSTFILBUF+6 ;
PACKDATA := FALSE ; (* DOUBLE WORD ALIGNMENT *)
%S0\ % MXDATASZE := REALSIZE ; \
%S1\ MXDATASZE := PTRSIZE ; (* DON'T CHANGE THIS ALONE !! *)
GET←STAT := FALSE ; ASMVERB := FALSE ;
%CTR\ CTRCNT := 0 ; CTROPTION := FALSE ;
END (*INITSCALARS*) ;
PROCEDURE INITSETS;
BEGIN
CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
SIMPTYPEBEGSYS := [LPARENT] + CONSTBEGSYS;
TYPEBEGSYS:=[ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY]+SIMPTYPEBEGSYS;
TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,
BEGINSY];
SELECTSYS := [ARROW,PERIOD,LBRACK];
FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY,
CASESY];
ATOZ := ['A','B','C','D','E','F','G','H','I','J','K','L','M','N','O'] ;
ATOZ := ATOZ + ['P','Q','R','S','T','U','V','W','X','Y','Z'] ;
NUMERIC := ['0','1','2','3','4','5','6','7','8','9'] ;
ALPHANUMERIC := ATOZ + NUMERIC + ['$','←']
END (*INITSETS*) ;
PROCEDURE INITTABLES;
PROCEDURE RESWORDS;
BEGIN
RW[ 1]:= 'IF '; RW[ 2]:= 'DO '; RW[ 3]:= 'OF ';
RW[ 4]:= 'TO '; RW[ 5]:= 'IN '; RW[ 6]:= 'OR ';
RW[ 7]:= 'END '; RW[ 8]:= 'FOR '; RW[ 9]:= 'VAR ';
RW[10]:= 'DIV '; RW[11]:= 'MOD '; RW[12]:= 'SET ';
RW[13]:= 'AND '; RW[14]:= 'NOT '; RW[15]:= 'THEN ';
RW[16]:= 'ELSE '; RW[17]:= 'WITH '; RW[18]:= 'GOTO ';
RW[19]:= 'CASE '; RW[20]:= 'TYPE ';
RW[21]:= 'FILE '; RW[22]:= 'BEGIN ';
RW[23]:= 'UNTIL '; RW[24]:= 'WHILE '; RW[25]:= 'ARRAY ';
RW[26]:= 'CONST '; RW[27]:= 'LABEL ';
RW[28]:= 'REPEAT '; RW[29]:= 'RECORD '; RW[30]:= 'DOWNTO ';
RW[31]:= 'PACKED '; RW[32]:= 'FORWARD '; RW[33]:= 'PROGRAM ';
RW[34]:= 'FUNCTION '; RW[35]:= 'PROCEDURE ';
FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 22;
FRW[6] := 28; FRW[7] := 32; FRW[8] := 34; FRW[9] := 35;
FRW[10] := 36 ; FRW[11] := 36; FRW[12] := 36; FRW[13] := 36 ;
%SEQFLD[9] := ' '; SEQFLD[10] := ' '; \ (*CLEAR EXTRA CHARS IN SEQ. FLD*)
END (*RESWORDS*) ;
PROCEDURE SYMBOLS;
BEGIN
RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY;
RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY;
RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY;
RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY;
RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY;
RSY[19] := CASESY; RSY[20] := TYPESY; RSY[21] := FILESY;
RSY[22] := BEGINSY; RSY[23] := UNTILSY; RSY[24] := WHILESY;
RSY[25] := ARRAYSY; RSY[26] := CONSTSY; RSY[27] := LABELSY;
RSY[28] := REPEATSY; RSY[29] := RECORDSY; RSY[30] := DOWNTOSY;
RSY[31] := PACKEDSY; RSY[32] := FORWARDSY; RSY[33] := PROGSY;
RSY[34] := FUNCSY; RSY[35] := PROCSY;
SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP;
SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT;
SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY;
SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY;
SSY['!'] := LBRACK; SSY['?'] := RBRACK; SSY[':'] := COLON;
(*EJG 12FEB78 : *)
(**) SSY['['] := LBRACK; SSY[']'] := RBRACK;
SSY['%'] := LBRACK; SSY['|'] := ADDOP ; SSY['&'] := MULOP ;
SSY['↑'] := ARROW; SSY['<'] := RELOP; SSY['>'] := RELOP;
%SSY['¬'] := NOTSY;\ SSY[';'] := SEMICOLON;
END (*SYMBOLS*) ;
PROCEDURE RATORS;
VAR I: INTEGER; CH: CHAR;
BEGIN
FOR I := 1 TO 35 (*NR OF RES WORDS*) DO ROP[I] := NOOP;
ROP[5] := INOP; ROP[10] := IDIV; ROP[11] := IMOD;
ROP[6] := OROP; ROP[13] := ANDOP;
(*EJG 12FEB78 : *)
(**) FOR CH := ' ' TO '←' DO SOP[CH] := NOOP;
SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
SOP['='] := EQOP;
SOP['<'] := LTOP; SOP['>'] := GTOP;
SOP['|'] := OROP ; SOP['&'] := ANDOP ;
END (*RATORS*) ;
PROCEDURE PROCMNEMONICS;
BEGIN
SNA[ 1] :='GET'; SNA[ 2] :='PUT'; SNA[ 3] :='RES'; SNA[ 4] :='REW';
SNA[ 5] :='RDC'; SNA[ 6] :='WRI'; SNA[ 7] :='WRO'; SNA[ 8] :='WRR';
SNA[ 9] :='WRC'; SNA[10] :='WRS'; SNA[11] :='PAK'; SNA[12] :='RDB';
SNA[13] :='WRB'; SNA[14] :='ELN'; SNA[15] :='SIN'; SNA[16] :='COS';
SNA[17] :='EXP'; SNA[18] :='SQT'; SNA[19] :='LOG'; SNA[20] :='ATN';
SNA[21] :='XIT'; SNA[22] :='WLN'; SNA[23] :='EOF'; SNA[24] :='RDI';
SNA[25] :='RDR'; SNA[26] :='RLN'; SNA[27] :='RDS'; SNA[28] :='TRP';
SNA[29] :='SIO'; SNA[30] :='EIO'; SNA[31] :='CLK';
END (*PROCMNEMONICS*) ;
PROCEDURE INSTRMNEMONICS;
BEGIN
MN[0] :=' ABI'; MN[1] :=' ABR'; MN[2] :=' ADI'; MN[3] :=' ADR';
MN[4] :=' AND'; MN[5] :=' DIF'; MN[6] :=' DVI'; MN[7] :=' DVR';
MN[8] :=' EOF'; MN[9] :=' FLO'; MN[10] :=' FLT'; MN[11] :=' INN';
MN[12] :=' INT'; MN[13] :=' IOR'; MN[14] :=' MOD'; MN[15] :=' MPI';
MN[16] :=' MPR'; MN[17] :=' NGI'; MN[18] :=' NGR'; MN[19] :=' NOT';
MN[20] :=' ODD'; MN[21] :=' SBI'; MN[22] :=' SBR'; MN[23] :=' SGS';
MN[24] :=' SQI'; MN[25] :=' SQR'; MN[26] :=' STO'; MN[27] :=' TRC';
MN[28] :=' UNI'; MN[29] :=' STP'; MN[30] :=' CSP'; MN[31] :=' DEC';
MN[32] :=' ENT'; MN[33] :=' FJP'; MN[34] :=' INC'; MN[35] :=' IND';
MN[36] :=' IXA'; MN[37] :=' LCA'; MN[38] :=' CTS'; MN[39] :=' CTI';
MN[40] :=' MOV'; MN[41] :=' MST'; MN[42] :=' RET'; MN[43] :=' ';
MN[44] :=' XJP'; MN[45] :=' CHK'; MN[46] :=' CUP'; MN[47] :=' EQU';
MN[48] :=' GEQ'; MN[49] :=' GRT'; MN[50] :=' LDA'; MN[51] :=' LDC';
MN[52] :=' LEQ'; MN[53] :=' LES'; MN[54] :=' LOD'; MN[55] :=' NEQ';
MN[56] :=' STR'; MN[57] :=' UJP'; MN[58] :=' NEW'; MN[59] :=' SAV';
MN[60] :=' RST'; MN[61] :=' ORD'; MN[62] :=' CHR'; MN[63] :=' DEF';
%S1\ MN[64] :=' PAR';
END (*INSTRMNEMONICS*) ;
BEGIN (*INITTABLES*)
RESWORDS; SYMBOLS; RATORS;
INSTRMNEMONICS; PROCMNEMONICS;
END (*INITTABLES*) ;
BEGIN (*PASCALCOMPILER*)
(*INITIALIZE*)
(************)
INITSCALARS; INITSETS; INITTABLES;
(*ENTER STANDARD NAMES AND STANDARD TYPES:*)
(******************************************)
LEVEL := 0; TOP := 0;
WITH DISPLAY[0] DO
BEGIN FNAME := NIL; FLABEL := NIL; OCCUR := BLCK END;
ENTERSTDTYPES; STDNAMES; ENTSTDNAMES; ENTERUNDECL;
TOP := 1; LEVEL := 1;
WITH DISPLAY[1] DO
BEGIN FNAME := NIL; FLABEL := NIL; OCCUR := BLCK END;
(*COMPILE:*)
(**********)
WRITELN(OUTPUT, ' LINE P/D LC LVL ',
'< STANFORD PASCAL←P COMPILER, VERSION OF SEP.-77 >' ) ;
WRITELN(OUTPUT) ; CTIME := CLOCK ;
INSYMBOL;
PROGRAMME(BLOCKBEGSYS+STATBEGSYS-[CASESY]);
CTIME := (CLOCK-CTIME) DIV 10 ; WRITELN(OUTPUT) ; WRITELN(OUTPUT) ;
IF ERRORCOUNT = 0 THEN WRITE(OUTPUT,'**** NO':19)
ELSE WRITE(OUTPUT,'****':14,ERRORCOUNT:5) ;
WRITELN(OUTPUT, ' SYNTAX ERROR(S) DETECTED.') ; WRITELN(OUTPUT) ;
WRITELN(OUTPUT, '****':14, LINECOUNT:6,' LINE(S) READ, ',PROCLAB:4,
' PROCEDURE(S) COMPILED,'); WRITELN() ;
WRITELN('****':14, OLDIC:6,' P←INSTRUCTIONS GENERATED,',
CTIME DIV 100 :4, '.', CTIME:2, ' SECONDS IN COMPILATION.') ;
if ERRORCOUNT <> 0 then EXITT(ERRORCOUNT) ;
END. (*PASCALCOMPILER*)